eidolon/Handler/Commons.hs

391 lines
14 KiB
Haskell
Executable File

-- 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 <http://www.gnu.org/licenses/>.
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