eidolon/Handler/Upload.hs

227 lines
8.3 KiB
Haskell
Raw Permalink Normal View History

2015-01-18 19:44:41 +00:00
-- 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
2015-01-21 09:00:18 +00:00
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-01-18 19:44:41 +00:00
module Handler.Upload where
2014-08-13 16:18:35 +00:00
import Import as I
import Yesod.Text.Markdown
import Text.Markdown
import Handler.Commons
2014-08-13 16:18:35 +00:00
import Data.Time
import Data.Maybe
2014-09-24 21:03:18 +00:00
import qualified Data.Text as T
2015-01-16 00:23:02 +00:00
import Data.List as L
2014-12-02 07:02:40 +00:00
import qualified System.FilePath as FP
2016-05-04 00:27:24 +00:00
import System.Directory
2017-04-26 19:43:22 +00:00
import Text.Blaze
2017-03-09 17:30:40 +00:00
-- import Codec.ImageType
-- import Codec.Picture as P
-- import Codec.Picture.Metadata as PM
-- import Codec.Picture.ScaleDCT
2016-11-19 21:13:02 +00:00
import Graphics.Rasterific.Svg as SVG
2017-03-09 17:30:40 +00:00
-- import Graphics.Svg
-- import Graphics.Text.TrueType
2014-08-13 16:18:35 +00:00
2017-01-07 22:18:25 +00:00
import Debug.Trace
2014-08-26 02:39:13 +00:00
getDirectUploadR :: AlbumId -> Handler Html
getDirectUploadR albumId = do
tempAlbum <- runDB $ get albumId
case tempAlbum of -- does the requested album exist
Just album -> do
2015-09-14 16:54:46 +00:00
let ownerId = albumOwner album
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of -- is anybody logged in
Just username -> do
(Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
2015-09-14 16:54:46 +00:00
if
userId == ownerId || userId `elem` albumShares album
-- is the owner present or a user with whom the album is shared
then do
2016-12-18 23:57:39 +00:00
(dUploadWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId
2016-08-30 12:22:00 +00:00
defaultLayout $ do
2015-09-14 16:54:46 +00:00
setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` albumTitle album)
2014-08-26 02:39:13 +00:00
$(widgetFile "dUpload")
2015-09-14 16:54:46 +00:00
else do
2014-08-26 02:39:13 +00:00
setMessage "You must own this album to upload"
redirect $ AlbumR albumId
Nothing -> do
setMessage "You must be logged in to upload"
2017-04-24 05:46:34 +00:00
redirect $ AuthR LoginR
2014-08-26 02:39:13 +00:00
Nothing -> do
setMessage "This album does not exist"
2015-09-14 16:54:46 +00:00
redirect HomeR
2014-08-26 02:39:13 +00:00
postDirectUploadR :: AlbumId -> Handler Html
postDirectUploadR albumId = do
tempAlbum <- runDB $ get albumId
case tempAlbum of -- does the album exist
Just album -> do
2015-09-14 16:54:46 +00:00
let ownerId = albumOwner album
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of -- is anybody logged in
Just username -> do
(Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
2015-10-19 06:32:47 +00:00
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
2014-08-26 02:39:13 +00:00
Nothing -> do
setMessage "You must be logged in to upload"
redirect $ AlbumR albumId
Nothing -> do
setMessage "This Album does not exist"
redirect $ AlbumR albumId
2016-12-18 23:57:39 +00:00
dUploadForm :: UserId -> User -> AlbumId -> AForm Handler FileBulk
dUploadForm userId user albumId = FileBulk
2015-10-19 06:32:47 +00:00
<$> areq textField (bfs ("Title" :: T.Text)) Nothing
2015-01-16 00:23:02 +00:00
<*> areq multiFileField "Select file(s)" Nothing
<*> lift (liftIO getCurrentTime)
<*> pure userId
<*> aopt markdownField (bfs ("Description" :: T.Text)) Nothing
2015-10-19 06:32:47 +00:00
<*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing
2015-01-16 00:23:02 +00:00
<*> pure albumId
2016-12-18 23:40:21 +00:00
<*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (defLicence)
2016-11-19 21:13:02 +00:00
<* bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
2016-12-18 23:40:21 +00:00
where
2017-08-06 02:42:31 +00:00
licences = optionsPairs $ I.map (\a -> (T.pack (show a), (a :: Licence)))
[minBound..maxBound]
2016-12-18 23:57:39 +00:00
defLicence = Just $ userDefaultLicence user
2017-04-26 19:43:22 +00:00
2015-01-16 00:23:02 +00:00
data FileBulk = FileBulk
2016-11-19 21:13:02 +00:00
{ fileBulkPrefix :: T.Text
2015-01-16 00:23:02 +00:00
, fileBulkFiles :: [FileInfo]
, fileBulkTime :: UTCTime
, fileBulkOwner :: UserId
, fileBulkDesc :: Maybe Markdown
2016-11-19 21:13:02 +00:00
, fileBulkTags :: [T.Text]
2015-01-16 00:23:02 +00:00
, fileBulkAlbum :: AlbumId
2017-08-06 02:42:31 +00:00
, fileBulkLicence :: Licence
2015-01-16 00:23:02 +00:00
}
getUploadR :: Handler Html
getUploadR = do
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of
Just username -> do
(Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
2015-09-14 16:54:46 +00:00
let albums = userAlbums user
if
I.null albums
then do
setMessage "Please create an album first"
redirect NewAlbumR
else do
2016-12-18 23:57:39 +00:00
(uploadWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user
2016-08-30 12:22:00 +00:00
defaultLayout $ do
2015-01-16 00:23:02 +00:00
setTitle "Eidolon :: Upload Medium"
$(widgetFile "bulkUpload")
Nothing -> do
setMessage "You need to be logged in"
2017-04-24 05:46:34 +00:00
redirect $ AuthR LoginR
2015-01-16 00:23:02 +00:00
2016-12-18 23:35:49 +00:00
bulkUploadForm :: UserId -> User -> AForm Handler FileBulk
2016-12-18 23:57:39 +00:00
bulkUploadForm userId user = (\a b c d e f g h -> FileBulk b c d e f g a h)
2015-10-19 06:32:47 +00:00
<$> areq (selectField albums) (bfs ("Album" :: T.Text)) Nothing
<*> areq textField (bfs ("Title" :: T.Text)) Nothing
2015-01-16 00:23:02 +00:00
<*> areq multiFileField "Select file(s)" Nothing
2014-08-13 16:18:35 +00:00
<*> lift (liftIO getCurrentTime)
2014-08-13 20:30:48 +00:00
<*> pure userId
<*> aopt markdownField (bfs ("Description" :: T.Text)) Nothing
2015-10-19 06:32:47 +00:00
<*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing
2016-12-18 23:40:21 +00:00
<*> areq (selectField licences) (bfs ("Licence" :: T.Text)) (defLicence)
2016-11-19 21:13:02 +00:00
<* bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
2014-08-13 22:52:32 +00:00
where
albums = do
allEnts <- runDB $ selectList [] [Desc AlbumTitle]
let entities = catMaybes $ map (\ent ->
2015-09-14 16:54:46 +00:00
if
userId == albumOwner (entityVal ent) || userId `elem` albumShares (entityVal ent)
then Just ent
else Nothing
) allEnts
2014-08-13 22:52:32 +00:00
optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
2017-08-06 02:42:31 +00:00
licences = optionsPairs $ I.map (\a -> (T.pack (show a), (a :: Licence)))
[minBound..maxBound]
2016-12-18 23:57:39 +00:00
defLicence = Just $ userDefaultLicence user
2014-08-13 16:18:35 +00:00
2015-01-16 00:23:02 +00:00
postUploadR :: Handler Html
postUploadR = do
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of
Just username -> do
(Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
2016-12-18 23:57:39 +00:00
((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user
2015-01-16 00:23:02 +00:00
case result of
FormSuccess temp -> do
onlyErrNames <- handleUploads temp
2015-09-14 16:54:46 +00:00
if
L.null onlyErrNames
then do
2015-01-16 00:23:02 +00:00
setMessage "All images succesfully uploaded"
redirect $ AlbumR $ fileBulkAlbum temp
2015-09-14 16:54:46 +00:00
else do
2017-04-26 19:43:22 +00:00
let msg = toMarkup $
"File type not supported of: "
`T.append` T.intercalate ", " onlyErrNames
2015-01-16 00:23:02 +00:00
setMessage msg
redirect $ AlbumR $ fileBulkAlbum temp
2015-01-16 00:23:02 +00:00
_ -> do
setMessage "There was an error uploading the file(s)"
2015-09-14 16:54:46 +00:00
redirect UploadR
2015-01-16 00:23:02 +00:00
Nothing -> do
setMessage "You need to be logged in"
2017-04-24 05:46:34 +00:00
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