make media replacable
This commit is contained in:
nek0
parent
c374443fdc
commit
154e211e19
3 changed files with 214 additions and 158 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,26 +86,16 @@ 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
|
||||
(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
|
||||
|
|
@ -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,40 +207,16 @@ 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
|
||||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue