-- 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.Metadata.Exif as PM import Codec.Picture.ScaleDCT import Codec.Picture.Extra import Codec.ImageType import Graphics.Svg import Graphics.Rasterific.Svg import Graphics.Text.TrueType import Graphics.HsExif import Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk.Poppler.Document import Graphics.UI.Gtk.Poppler.Page 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 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 return img "application/pdf" -> do curDir <- liftIO getCurrentDirectory mpdf <- liftIO $ documentNewFromFile ("file://" ++ (curDir path)) Nothing case mpdf of Nothing -> error "Empty pdf" Just pdf -> do page0 <- liftIO $ documentGetPage pdf 0 (pw, ph) <- liftIO $ pageGetSize page0 let tempPath = FP.takeBaseName path ++ "_temp.png" liftIO $ withImageSurface FormatARGB32 (floor pw) (floor ph) $ \surf -> do renderWith surf $ do setSourceRGB 1 1 1 Cairo.rectangle 0 0 pw ph fill pageRender page0 surfaceWriteToPNG surf tempPath edynimg <- liftIO $ readPng tempPath case edynimg of Left err -> do liftIO $ removeFile (FP.normalise tempPath) error err Right dynimg -> do let img = convertRGBA8 dynimg liftIO $ removeFile (FP.normalise tempPath) return img _ -> do eimg <- liftIO $ readImage path case eimg of Left err -> error err Right img -> do meta <- liftIO $ parseFileExif path -- error $ show meta case meta of Left _ -> return $ convertRGBA8 img Right metamap -> case getOrientation metamap of Just Mirror -> return $ flipHorizontally $ convertRGBA8 img Just (Rotation rot) -> case rot of HundredAndEighty -> return $ rotate180 $ convertRGBA8 img MinusNinety -> return $ rotateRight90 $ convertRGBA8 img Ninety -> return $ rotateLeft90 $ convertRGBA8 img Just (MirrorRotation rot) -> case rot of HundredAndEighty -> return $ flipVertically $ convertRGBA8 img MinusNinety -> return $ flipHorizontally $ rotateRight90 $ convertRGBA8 img Ninety -> return $ rotate180 $ convertRGBA8 img _ -> 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 $ 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 "application/pdf" -> return True -- PDF is inherently insecure. can't check here. _ -> 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