diff --git a/Handler/Commons.hs b/Handler/Commons.hs index 727134a..59ce7cd 100755 --- a/Handler/Commons.hs +++ b/Handler/Commons.hs @@ -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 diff --git a/Handler/MediumSettings.hs b/Handler/MediumSettings.hs index 377e379..50b7ab5 100755 --- a/Handler/MediumSettings.hs +++ b/Handler/MediumSettings.hs @@ -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 diff --git a/Handler/Upload.hs b/Handler/Upload.hs index 9dd5ea5..5cb14eb 100755 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -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