make media replacable

This commit is contained in:
nek0 2017-03-09 18:30:40 +01:00
parent c374443fdc
commit 154e211e19
3 changed files with 214 additions and 158 deletions

View file

@ -20,8 +20,19 @@ import Import
import qualified Data.Text as T
import Data.String
import qualified Data.List as L
import Data.Time
import Data.Maybe (fromJust)
import Data.Int (Int64(..))
import System.FilePath as FP
import System.Directory
import Text.Markdown
import Codec.Picture as P
import Codec.Picture.Metadata as PM hiding (insert, delete)
import Codec.Picture.ScaleDCT
import Codec.ImageType
import Graphics.Svg
import Graphics.Rasterific.Svg
import Graphics.Text.TrueType
loginIsAdmin :: IsString t => Handler (Either (t, Route App) ())
loginIsAdmin = do
@ -152,3 +163,145 @@ removeReference mId aId = do
let newMediaList = removeItem mId $ albumContent album
-- update reference list
runDB $ update aId [AlbumContent =. newMediaList]
data UploadSpec
= NewFile
| Replace MediumId
handleUpload
:: Int
-> AlbumId
-> T.Text
-> UTCTime
-> UserId
-> Maybe Markdown
-> [T.Text]
-> Int
-> UploadSpec
-> (Int, FileInfo)
-> Handler (Maybe T.Text)
handleUpload len albumId prefix time owner desc tags licence spec (index, file) = do
let mime = fileContentType file
if mime `elem` acceptedTypes
then do
albRef <- runDB $ getJust albumId
let ownerId = albumOwner albRef
path <- writeOnDrive file ownerId albumId spec
isOk <- liftIO $ checkCVE_2016_3714 path mime
if isOk
then do
meta <- generateThumbs path ownerId albumId mime
tempName <- if len == 1
then return prefix
else return
( prefix `T.append` " " `T.append` T.pack (show index) `T.append`
" of " `T.append` T.pack (show len))
medium <- return $ Medium
tempName
('/' : path)
('/' : metaThumbPath meta)
mime
time
owner
desc
tags
albumId
('/' : metaPreviewPath meta)
licence
case spec of
NewFile ->
insertMedium medium albumId
Replace _ ->
return ()
return Nothing
else do
liftIO $ removeFile (FP.normalise path)
return $ Just $ fileName file
else
return $ Just $ fileName file
data ThumbsMeta = ThumbsMeta
{ metaThumbPath :: FP.FilePath
, metaPreviewPath :: FP.FilePath
}
-- | generate thumbnail and preview images from uploaded image
generateThumbs
:: FP.FilePath -- ^ Path to original image
-> UserId -- ^ Uploading user
-> AlbumId -- ^ Destination album
-> T.Text -- ^ MIME-Type (used for svg et al.)
-> Handler ThumbsMeta -- ^ Resulting metadata to store
generateThumbs path uId aId mime = do
orig <- case mime of
"image/svg+xml" -> do
svg <- liftIO $ loadSvgFile path
(img, _) <- liftIO $ renderSvgDocument emptyFontCache Nothing 100 $ fromJust svg
return img
_ -> do
eimg <- liftIO $ readImage path
case eimg of
Left err ->
error err
Right img -> -- This branch contains "classical" image formats like bmp or png
return $ convertRGBA8 img
let thumbName = FP.takeBaseName path ++ "_thumb.png"
prevName = FP.takeBaseName path ++ "_preview.png"
pathPrefix = "static" FP.</> "data" FP.</> T.unpack (extractKey uId) FP.</> T.unpack (extractKey aId)
tPath = pathPrefix FP.</> thumbName
pPath = pathPrefix FP.</> prevName
-- origPix = convertRGBA8 orig
oWidth = P.imageWidth orig :: Int
oHeight = P.imageHeight orig :: Int
tWidth = floor (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double)
tHeight = 230 :: Int
pHeight = 600 :: Int
pScale = (fromIntegral pHeight :: Double) / (fromIntegral oHeight :: Double)
pWidth = floor (fromIntegral oWidth * pScale)
tPix = scale (tWidth, tHeight) orig
pPix = scale (pWidth, pHeight) orig
liftIO $ savePngImage tPath $ ImageRGBA8 tPix
liftIO $ savePngImage pPath $ ImageRGBA8 pPix
return $ ThumbsMeta
{ metaThumbPath = tPath
, metaPreviewPath = pPath
}
checkCVE_2016_3714 :: FP.FilePath -> T.Text -> IO Bool
checkCVE_2016_3714 p m =
case m of
"image/jpeg" -> isJpeg p
"image/jpg" -> isJpeg p
"image/png" -> isPng p
"image/x-ms-bmp" -> isBmp p
"image/x-bmp" -> isBmp p
"image/bmp" -> isBmp p
"image/tiff" -> isTiff p
"image/tiff-fx" -> isTiff p
"image/svg+xml" -> return True -- TODO: have to check XML for that.
"image/gif" -> isGif p
_ -> return False
writeOnDrive :: FileInfo -> UserId -> AlbumId -> UploadSpec -> Handler FP.FilePath
writeOnDrive fil userId albumId spec = do
album <- runDB $ getJust albumId
let ac = albumContent album
[PersistInt64 int] <- case spec of
NewFile ->
if L.null ac then return [PersistInt64 1] else return $ keyToValues $ maximum $ ac
Replace mId -> do
medium <- runDB $ getJust mId
return $ (PersistInt64 (read $ takeBaseName $ mediumPath medium :: Int64)) : []
let filen = show $ fromIntegral int + case spec of
Replace _ -> 0
NewFile -> 1
ext = FP.takeExtension $ T.unpack $ fileName fil
path = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> filen ++ ext
dde <- liftIO $ doesDirectoryExist $ FP.dropFileName path
if not dde
then
liftIO $ createDirectoryIfMissing True $ FP.dropFileName path
else
return ()
liftIO $ fileMove fil path
return path

View file

@ -21,7 +21,9 @@ import Yesod.Text.Markdown
import Handler.Commons
import System.FilePath
import qualified Data.Text as T
import Data.Maybe (catMaybes)
import Data.Maybe
import Text.Markdown
import Control.Monad (when)
getMediumSettingsR :: MediumId -> Handler Html
getMediumSettingsR mediumId = do
@ -49,11 +51,26 @@ postMediumSettingsR mediumId = do
case result of
FormSuccess temp -> do
_ <- runDB $ update mediumId
[ MediumTitle =. mediumTitle temp
, MediumDescription =. mediumDescription temp
, MediumTags =. mediumTags temp
, MediumLicence =. mediumLicence temp
[ MediumTitle =. msTitle temp
, MediumDescription =. msDescription temp
, MediumTags =. msTags temp
, MediumLicence =. msLicence temp
]
when (not $ isNothing $ msData temp) $ do
err <- handleUpload
1
(mediumAlbum medium)
(msTitle temp)
(mediumTime medium)
(mediumOwner medium)
(msDescription temp)
(msTags temp)
(msLicence temp)
(Replace mediumId)
(1, (fromJust $ msData temp))
when (not $ isNothing err) $ do
setMessage "There was an error uploading the File"
redirect $ MediumSettingsR mediumId
setMessage "Medium settings changed succesfully"
redirect $ MediumR mediumId
_ -> do
@ -63,18 +80,20 @@ postMediumSettingsR mediumId = do
setMessage errorMsg
redirect route
mediumSettingsForm :: Medium -> AForm Handler Medium
mediumSettingsForm medium = Medium
data MediumSettings = MediumSettings
{ msTitle :: T.Text
, msData :: Maybe FileInfo
, msDescription :: Maybe Markdown
, msTags :: [T.Text]
, msLicence :: Int
}
mediumSettingsForm :: Medium -> AForm Handler MediumSettings
mediumSettingsForm medium = MediumSettings
<$> areq textField (bfs ("Title" :: T.Text)) (Just $ mediumTitle medium)
<*> pure (mediumPath medium)
<*> pure (mediumThumb medium)
<*> pure (mediumMime medium)
<*> pure (mediumTime medium)
<*> pure (mediumOwner medium)
<*> aopt fileField (bfs ("Update medium" :: T.Text)) (Nothing)
<*> aopt markdownField (bfs ("Description" :: T.Text)) (Just $ mediumDescription medium)
<*> areq tagField (bfs ("Tags" :: T.Text)) (Just $ mediumTags medium)
<*> pure (mediumAlbum medium)
<*> pure (mediumPreview medium)
<*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (Just $ mediumLicence medium)
<* bootstrapSubmit ("Change settings" :: BootstrapSubmit T.Text)
where

View file

@ -27,13 +27,13 @@ import Data.List as L
import qualified System.FilePath as FP
import System.Directory
import Text.Blaze.Internal
import Codec.ImageType
import Codec.Picture as P
import Codec.Picture.Metadata as PM
import Codec.Picture.ScaleDCT
-- import Codec.ImageType
-- import Codec.Picture as P
-- import Codec.Picture.Metadata as PM
-- import Codec.Picture.ScaleDCT
import Graphics.Rasterific.Svg as SVG
import Graphics.Svg
import Graphics.Text.TrueType
-- import Graphics.Svg
-- import Graphics.Text.TrueType
import Debug.Trace
@ -86,27 +86,17 @@ postDirectUploadR albumId = do
let fils = fileBulkFiles temp
let indFils = zip [1..] fils
errNames <- mapM
(\(index, file) -> do
let mime = fileContentType file
if mime `elem` acceptedTypes
then do
path <- writeOnDrive file ownerId albumId
isOk <- liftIO $ checkCVE_2016_3714 path mime
if isOk
then do
meta <- generateThumbs path ownerId albumId mime
tempName <- if length indFils == 1
then return $ fileBulkPrefix temp
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
let medium = Medium tempName ('/' : path) ('/' : metaThumbPath meta) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) albumId ('/' : metaPreviewPath meta) (fileBulkLicence temp)
insertMedium medium albumId
return Nothing
else do
liftIO $ removeFile (FP.normalise path)
return $ Just $ fileName file
else
return $ Just $ fileName file
) indFils
(handleUpload
(length indFils)
(fileBulkAlbum temp)
(fileBulkPrefix temp)
(fileBulkTime temp)
(fileBulkOwner temp)
(fileBulkDesc temp)
(fileBulkTags temp)
(fileBulkLicence temp)
NewFile
)indFils
let onlyErrNames = removeItem Nothing errNames
if
L.null onlyErrNames
@ -131,88 +121,6 @@ postDirectUploadR albumId = do
setMessage "This Album does not exist"
redirect $ AlbumR albumId
-- | Type to pass metadata about imgaes around.
data ThumbsMeta = ThumbsMeta
{ metaThumbPath :: FP.FilePath -- ^ Filepath of the new thumbnail image
, metaPreviewPath :: FP.FilePath -- ^ Filepath of the new preview image
}
-- | generate thumbnail and preview images from uploaded image
generateThumbs
:: FP.FilePath -- ^ Path to original image
-> UserId -- ^ Uploading user
-> AlbumId -- ^ Destination album
-> T.Text -- ^ MIME-Type (used for svg et al.)
-> Handler ThumbsMeta -- ^ Resulting metadata to store
generateThumbs path uId aId mime = do
orig <- case mime of
"image/svg+xml" -> do
svg <- liftIO $ loadSvgFile path
(img, _) <- liftIO $ renderSvgDocument emptyFontCache Nothing 100 $ fromJust svg
return img
_ -> do
eimg <- liftIO $ readImage path
case eimg of
Left err ->
error err
Right img -> do -- This branch contains "classical" image formats like bmp or png
liftIO $ traceIO "I am here!"
return $ convertRGBA8 img
let thumbName = FP.takeBaseName path ++ "_thumb.png"
prevName = FP.takeBaseName path ++ "_preview.png"
pathPrefix = "static" FP.</> "data" FP.</> T.unpack (extractKey uId) FP.</> T.unpack (extractKey aId)
tPath = pathPrefix FP.</> thumbName
pPath = pathPrefix FP.</> prevName
-- origPix = convertRGBA8 orig
oWidth = P.imageWidth orig :: Int
oHeight = P.imageHeight orig :: Int
tWidth = floor (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double)
tHeight = 230 :: Int
pHeight = 600 :: Int
pScale = (fromIntegral pHeight :: Double) / (fromIntegral oHeight :: Double)
pWidth = floor (fromIntegral oWidth * pScale)
tPix = scale (tWidth, tHeight) orig
pPix = scale (pWidth, pHeight) orig
liftIO $ savePngImage tPath $ ImageRGBA8 tPix
liftIO $ savePngImage pPath $ ImageRGBA8 pPix
return $ ThumbsMeta
{ metaThumbPath = tPath
, metaPreviewPath = pPath
}
checkCVE_2016_3714 :: FP.FilePath -> T.Text -> IO Bool
checkCVE_2016_3714 p m =
case m of
"image/jpeg" -> isJpeg p
"image/jpg" -> isJpeg p
"image/png" -> isPng p
"image/x-ms-bmp" -> isBmp p
"image/x-bmp" -> isBmp p
"image/bmp" -> isBmp p
"image/tiff" -> isTiff p
"image/tiff-fx" -> isTiff p
"image/svg+xml" -> return True -- TODO: have to check XML for that.
"image/gif" -> isGif p
_ -> return False
writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
writeOnDrive fil userId albumId = do
--filen <- return $ fileName fil
album <- runDB $ getJust albumId
let ac = albumContent album
[PersistInt64 int] = if L.null ac then [PersistInt64 1] else keyToValues $ maximum $ ac
filen = show $ fromIntegral int + 1
ext = FP.takeExtension $ T.unpack $ fileName fil
path = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> filen ++ ext
dde <- liftIO $ doesDirectoryExist $ FP.dropFileName path
if not dde
then
liftIO $ createDirectoryIfMissing True $ FP.dropFileName path
else
return ()
liftIO $ fileMove fil path
return path
dUploadForm :: UserId -> User -> AlbumId -> AForm Handler FileBulk
dUploadForm userId user albumId = FileBulk
<$> areq textField (bfs ("Title" :: T.Text)) Nothing
@ -299,41 +207,17 @@ postUploadR = do
let fils = fileBulkFiles temp
let indFils = zip [1..] fils
errNames <- mapM
(\(index, file) -> do
let mime = fileContentType file
if mime `elem` acceptedTypes
then do
let inAlbumId = fileBulkAlbum temp
albRef <- runDB $ getJust inAlbumId
let ownerId = albumOwner albRef
path <- writeOnDrive file ownerId inAlbumId
isOk <- liftIO $ checkCVE_2016_3714 path mime
if isOk
then do
meta <- generateThumbs path ownerId inAlbumId mime
tempName <- if
length indFils == 1
then return $ fileBulkPrefix temp
else
return
(fileBulkPrefix temp `T.append`
" " `T.append`
T.pack (show (index :: Int)) `T.append`
" of " `T.append`
T.pack (show (length indFils)))
let medium = Medium tempName ('/' : path) ('/' : metaThumbPath meta) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) inAlbumId ('/' : metaPreviewPath meta) (fileBulkLicence temp)
-- mId <- runDB $ I.insert medium
-- inALbum <- runDB $ getJust inAlbumId
-- let newMediaList = mId : albumContent inALbum
-- runDB $ update inAlbumId [AlbumContent =. newMediaList]
insertMedium medium inAlbumId
return Nothing
else do
liftIO $ removeFile (FP.normalise path)
return $ Just $ fileName file
else
return $ Just $ fileName file
) indFils
(handleUpload
(length indFils)
(fileBulkAlbum temp)
(fileBulkPrefix temp)
(fileBulkTime temp)
(fileBulkOwner temp)
(fileBulkDesc temp)
(fileBulkTags temp)
(fileBulkLicence temp)
NewFile
)indFils
let onlyErrNames = removeItem Nothing errNames
if
L.null onlyErrNames