-- eidolon -- A simple gallery in Haskell and Yesod -- Copyright (C) 2015 Amedeo Molnár -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published -- by the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module Handler.Commons where import Import import Scale 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 import Debug.Trace loginIsAdmin :: IsString t => Handler (Either (t, Route App) ()) loginIsAdmin = do musername <- maybeAuthId case musername of Just username -> do (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username if userAdmin user then return $ Right () else return $ Left ("You have no admin rights", HomeR) Nothing -> return $ Left ("You are not logged in", AuthR LoginR) profileCheck :: IsString t => UserId -> Handler (Either (t, Route App) User) profileCheck userId = do tempUser <- runDB $ get userId case tempUser of Just user -> do musername <- maybeAuthId case musername of Just username -> do (Just (Entity loginId _)) <- runDB $ getBy $ UniqueUser username if loginId == userId then return $ Right user else return $ Left ("You can only change your own profile settings", UserR $ userName user) Nothing -> return $ Left ("You nedd to be logged in to change settings", AuthR LoginR) Nothing -> return $ Left ("This user does not exist", HomeR) mediumCheck :: IsString t => MediumId -> Handler (Either (t, Route App) Medium) mediumCheck mediumId = do tempMedium <- runDB $ get mediumId case tempMedium of Just medium -> do let ownerId = mediumOwner medium musername <- maybeAuthId case musername of Just username -> do (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username album <- runDB $ getJust $ mediumAlbum medium let presence = userId == ownerId albumOwnerPresence = userId == albumOwner album if presence || albumOwnerPresence then return $ Right medium else return $ Left ("You must own this medium to change its settings", MediumR mediumId) Nothing -> return $ Left ("You must be logged in to change settings", AuthR LoginR) Nothing -> return $ Left ("This medium does not exist", HomeR) insertMedium :: Medium -> AlbumId -> Handler () insertMedium medium aId = do mId <- runDB $ insert medium inAlbum <- runDB $ getJust aId let newMediaList = mId : albumContent inAlbum runDB $ update aId [AlbumContent =. newMediaList] deleteMedium :: MediumId -> Medium -> Handler () deleteMedium mId medium = do commEnts <- runDB $ selectList [CommentOrigin ==. mId] [] -- delete comments first mapM_ (runDB . delete . entityKey) commEnts -- remove reference removeReference mId $ mediumAlbum medium -- delete Files mapM_ (liftIO . removeFile . normalise . L.tail) [ mediumPath medium , mediumThumb medium , mediumPreview medium ] -- delete database entry runDB $ delete mId moveMedium :: Medium -> MediumId -> AlbumId -> Handler () moveMedium med mId destId = do $(logError) "getting destination" dest <- runDB $ getJust destId -- remove reference $(logError) "removing reference" removeReference mId $ mediumAlbum med -- move physical Files -- let filen = show $ length (albumContent dest) + 1 let ac = albumContent dest [PersistInt64 int] = if L.null ac then [PersistInt64 1] else keyToValues $ maximum $ ac filen = show $ fromIntegral int + 1 ext = takeExtension $ mediumPath med prefix = "static" "data" T.unpack (extractKey $ albumOwner dest) T.unpack (extractKey destId) nPath = prefix filen ++ ext nThumb = prefix takeBaseName nPath ++ "_thumb.jpg" nPrev = prefix takeBaseName nPath ++ "_preview.jpg" $(logError) $ T.pack $ "copyFile" ++ nPath liftIO $ copyFile (L.tail $ mediumPath med) nPath liftIO $ copyFile (L.tail $ mediumThumb med) nThumb liftIO $ copyFile (L.tail $ mediumPreview med) nPrev -- remove physical files $(logError) "removeFile" mapM_ (liftIO . removeFile . normalise . L.tail) [ mediumPath med , mediumThumb med , mediumPreview med ] -- chenge filenames in database runDB $ update mId [ MediumPath =. '/' : nPath , MediumThumb =. '/' : nThumb , MediumPreview =. '/' : nPrev , MediumAlbum =. destId ] -- create new references let newMediaList = mId : albumContent dest runDB $ update destId [AlbumContent =. newMediaList] removeReference :: MediumId -> AlbumId -> Handler () removeReference mId aId = do -- delete references next album <- runDB $ getJust aId let newMediaList = removeItem mId $ albumContent album -- update reference list runDB $ update aId [AlbumContent =. newMediaList] data UploadSpec = NewFile | Replace MediumId -- | function to handle uploaded media files handleUpload :: Int -- ^ number of uploaded media -> AlbumId -- ^ 'AlbumId' of destination album -> T.Text -- ^ Title or title prefix -> UTCTime -- ^ Time of upload -> UserId -- ^ 'UserId' of media owner -> Maybe Markdown -- ^ Description text -> [T.Text] -- ^ Tags -> Licence -- ^ Licence -> UploadSpec -- ^ New file or replacement file? -> (Int, FileInfo) -- ^ actual file -> Handler (Maybe T.Text) -- ^ Returns the filename if something fails 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)) case spec of NewFile -> do medium <- return $ Medium tempName ('/' : path) ('/' : metaThumbPath meta) mime time owner desc tags albumId ('/' : metaPreviewPath meta) licence insertMedium medium albumId Replace mId -> runDB $ update mId [ MediumPath =. ('/' : path) ] 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 liftIO $ traceIO "------------------> SVG loaded!" let (swidth, sheight) = documentSize 100 (fromJust svg) scale = let picScale = (fromIntegral swidth / fromIntegral sheight) :: Double nwidth = if swidth < 1000 then 1000 :: Int else swidth nheight = if swidth < 1000 then floor (1000 / picScale) else sheight in Just (nwidth, nheight) (img, _) <- liftIO $ renderSvgDocument emptyFontCache scale 100 $ fromJust svg liftIO $ traceIO "------------------> SVG rendered!" 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 tHeight = 230 :: Int pHeight = 600 :: Int tWidth = ceiling (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double) pScale = (fromIntegral pHeight :: Double) / (fromIntegral oHeight :: Double) pWidth = ceiling (fromIntegral oWidth * pScale) tPix = scaleBilinearAlpha tWidth tHeight orig pPix = scaleBilinearAlpha pWidth pHeight orig liftIO $ traceIO $ show oWidth liftIO $ traceIO "------------------> Image scaled!" liftIO $ savePngImage tPath $ ImageRGBA8 tPix liftIO $ traceIO "------------------> Saved thumbnail!" liftIO $ savePngImage pPath $ ImageRGBA8 pPix liftIO $ traceIO "------------------> Saved preview!" 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 0] 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