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

import Debug.Trace

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
      musername <- maybeAuthId
      case musername of -- is anybody logged in
        Just username -> do
          (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
          if
            userId == ownerId || userId `elem` albumShares album
            -- is the owner present or a user with whom the album is shared
            then do
              (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 $ AuthR 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
      musername <- maybeAuthId
      case musername of -- is anybody logged in
        Just username -> do
          (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
          if userId == ownerId || userId `elem` albumShares album
          -- is the logged in user the owner or is the album shared with him
          then do
            ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId
            case result of
              FormSuccess temp -> do
                onlyErrNames <- handleUploads temp
                if L.null onlyErrNames
                then do
                  setMessage "All images succesfully uploaded"
                  redirect $ AlbumR albumId
                else do
                  let msg = toMarkup $
                        "File type not supported of: " `T.append`
                        (T.intercalate ", " onlyErrNames)
                  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

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
  musername <- maybeAuthId
  case musername of
    Just username -> do
      (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
      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 $ AuthR 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
  musername <- maybeAuthId
  case musername of
    Just username -> do
      (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
      ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user
      case result of
        FormSuccess temp -> do
          onlyErrNames <- handleUploads temp
          if
            L.null onlyErrNames
            then do
              setMessage "All images succesfully uploaded"
              redirect $ AlbumR $ fileBulkAlbum temp
            else do
              let msg = toMarkup $
                    "File type not supported of: "
                    `T.append` T.intercalate ", " onlyErrNames
              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 $ AuthR LoginR

handleUploads :: FileBulk -> Handler [Text]
handleUploads temp = do
  let fils = fileBulkFiles temp
      indFils = zip [1..] fils
  errNames <- mapM
    (handleUpload
      (length indFils)
      (fileBulkAlbum temp)
      (fileBulkPrefix temp)
      (fileBulkTime temp)
      (fileBulkOwner temp)
      (fileBulkDesc temp)
      (fileBulkTags temp)
      (fileBulkLicence temp)
      NewFile
    )indFils
  return $ catMaybes errNames