eidolon/Handler/Upload.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.Upload where

import Import as I
import Yesod.Text.Markdown
import Text.Markdown
import Handler.Commons
import Data.Time
import Data.Maybe
import qualified Data.Text as T
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 Graphics.Rasterific.Svg as SVG
import Graphics.Svg
import Graphics.Text.TrueType

getDirectUploadR :: AlbumId -> Handler Html
getDirectUploadR albumId = do
  tempAlbum <- runDB $ get albumId
  case tempAlbum of -- does the requested album exist
    Just album -> do
      let ownerId = albumOwner album
      msu <- lookupSession "userId"
      case msu of -- is anybody logged in
        Just tempUserId -> do
          let userId = getUserIdFromText tempUserId
          if
            userId == ownerId || userId `elem` albumShares album
            -- is the owner present or a user with whom the album is shared
            then do
              user <- runDB $ getJust userId
              (dUploadWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId
              defaultLayout $ do
                setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` albumTitle album)
                $(widgetFile "dUpload")
            else do
              setMessage "You must own this album to upload"
              redirect $ AlbumR albumId
        Nothing -> do
          setMessage "You must be logged in to upload"
          redirect LoginR
    Nothing -> do
      setMessage "This album does not exist"
      redirect HomeR

postDirectUploadR :: AlbumId -> Handler Html
postDirectUploadR albumId = do
  tempAlbum <- runDB $ get albumId
  case tempAlbum of -- does the album exist
    Just album -> do
      let ownerId = albumOwner album
      msu <- lookupSession "userId"
      case msu of -- is anybody logged in
        Just tempUserId -> do
          let userId = getUserIdFromText tempUserId
          if userId == ownerId || userId `elem` albumShares album
            -- is the logged in user the owner or is the album shared with him
            then do
              user <- runDB $ getJust userId
              ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId
              case result of
                FormSuccess temp -> 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
                  let onlyErrNames = removeItem Nothing errNames
                  if
                    L.null onlyErrNames
                    then do
                      setMessage "All images succesfully uploaded"
                      redirect $ AlbumR albumId
                    else do
                      let justErrNames = map fromJust onlyErrNames
                      let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
                      setMessage msg
                      redirect HomeR
                _ -> do
                  setMessage "There was an error uploading the file"
                  redirect $ DirectUploadR albumId
            else do -- owner is not present
              setMessage "You must own this album to upload"
              redirect $ AlbumR albumId
        Nothing -> do
          setMessage "You must be logged in to upload"
          redirect $ AlbumR albumId
    Nothing -> 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
  eimg <- liftIO $ readImage path
  orig <- case eimg of
    Left err -> -- This branch contains svg and other data formats. to be extended for pdf et al.
      case mime of
        "image/svg+xml" -> do
          svg <- liftIO $ loadSvgFile path
          (img, _) <- liftIO $ renderSvgDocument emptyFontCache Nothing 100 $ fromJust svg
          return img
        _ -> error err
    Right img -> do -- 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 -> 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
  <*> areq multiFileField "Select file(s)" Nothing
  <*> lift (liftIO getCurrentTime)
  <*> pure userId
  <*> aopt markdownField (bfs ("Description" :: T.Text)) Nothing
  <*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing
  <*> pure albumId
  <*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (defLicence)
  <*  bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
  where
    licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
    defLicence = Just $ userDefaultLicence user
      

data FileBulk = FileBulk
  { fileBulkPrefix :: T.Text
  , fileBulkFiles :: [FileInfo]
  , fileBulkTime :: UTCTime
  , fileBulkOwner :: UserId
  , fileBulkDesc :: Maybe Markdown
  , fileBulkTags :: [T.Text]
  , fileBulkAlbum :: AlbumId
  , fileBulkLicence :: Int
  }

getUploadR :: Handler Html
getUploadR = do
  msu <- lookupSession "userId"
  case msu of
    Just tempUserId -> do
      let userId = getUserIdFromText tempUserId
      user <- runDB $ getJust userId
      let albums = userAlbums user
      if
        I.null albums
        then do
          setMessage "Please create an album first"
          redirect NewAlbumR
        else do
          (uploadWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user
          defaultLayout $ do
            setTitle "Eidolon :: Upload Medium"
            $(widgetFile "bulkUpload")
    Nothing -> do
      setMessage "You need to be logged in"
      redirect LoginR

bulkUploadForm :: UserId -> User -> AForm Handler FileBulk
bulkUploadForm userId user = (\a b c d e f g h -> FileBulk b c d e f g a h)
  <$> areq (selectField albums) (bfs ("Album" :: T.Text)) Nothing
  <*> areq textField (bfs ("Title" :: T.Text)) Nothing
  <*> areq multiFileField "Select file(s)" Nothing
  <*> lift (liftIO getCurrentTime)
  <*> pure userId
  <*> aopt markdownField (bfs ("Description" :: T.Text)) Nothing
  <*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing
  <*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (defLicence)
  <*  bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
  where
    albums = do
      allEnts <- runDB $ selectList [] [Desc AlbumTitle]
      let entities = catMaybes $ map (\ent ->
            if
              userId == albumOwner (entityVal ent) || userId `elem` albumShares (entityVal ent)
              then Just ent
              else Nothing
            ) allEnts
      optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
    licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
    defLicence = Just $ userDefaultLicence user

postUploadR :: Handler Html
postUploadR = do
  msu <- lookupSession "userId"
  case msu of
    Just tempUserId -> do
      let userId = getUserIdFromText tempUserId
      user <- runDB $ getJust userId
      ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user
      case result of
        FormSuccess temp -> 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
          let onlyErrNames = removeItem Nothing errNames
          if
            L.null onlyErrNames
            then do
              setMessage "All images succesfully uploaded"
              redirect $ AlbumR $ fileBulkAlbum temp
            else do
              let justErrNames = map fromJust onlyErrNames
              let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
              setMessage msg
              redirect $ AlbumR $ fileBulkAlbum temp
        _ -> do
          setMessage "There was an error uploading the file(s)"
          redirect UploadR
    Nothing -> do
      setMessage "You need to be logged in"
      redirect LoginR