eidolon/Handler/Commons.hs

--  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