eidolon/Handler/Upload.hs

173 lines
6.3 KiB
Haskell
Raw Normal View History

module Handler.Upload where
2014-08-13 16:18:35 +00:00
import Import as I
import Data.Time
2014-09-24 21:03:18 +00:00
import qualified Data.Text as T
2014-08-13 16:18:35 +00:00
import System.FilePath
data TempMedium = TempMedium
{ tempMediumTitle :: Text
, tempMediumFile :: FileInfo
, tempMediumTime :: UTCTime
2014-08-13 20:30:48 +00:00
, tempMediumOwner :: UserId
2014-08-13 16:18:35 +00:00
, tempMediumDesc :: Textarea
, tempMediumTags :: [Text]
2014-08-13 22:52:32 +00:00
, tempMediumAlbum :: AlbumId
2014-08-13 16:18:35 +00:00
}
getUploadR :: Handler Html
2014-08-13 16:18:35 +00:00
getUploadR = do
2014-08-13 20:30:48 +00:00
msu <- lookupSession "userId"
2014-08-13 16:18:35 +00:00
case msu of
2014-08-13 20:30:48 +00:00
Just tempUserId -> do
2014-08-13 22:52:57 +00:00
userId <- lift $ pure $ getUserIdFromText tempUserId
2014-08-15 12:50:03 +00:00
(uploadWidget, enctype) <- generateFormPost (uploadForm userId)
2014-08-13 16:18:35 +00:00
defaultLayout $ do
2014-09-24 21:03:18 +00:00
setTitle "Eidolon :: Upload Medium"
2014-08-13 16:18:35 +00:00
$(widgetFile "upload")
Nothing -> do
2014-08-15 13:47:16 +00:00
setMessage "You need to be logged in"
2014-08-13 16:18:35 +00:00
redirect $ LoginR
postUploadR :: Handler Html
2014-08-13 16:18:35 +00:00
postUploadR = do
2014-08-13 20:30:48 +00:00
msu <- lookupSession "userId"
2014-08-13 16:18:35 +00:00
case msu of
2014-08-13 20:30:48 +00:00
Just tempUserId -> do
2014-08-13 22:52:57 +00:00
userId <- lift $ pure $ getUserIdFromText tempUserId
2014-08-15 12:50:03 +00:00
((result, uploadWidget), enctype) <- runFormPost (uploadForm userId)
2014-08-13 16:18:35 +00:00
case result of
FormSuccess temp -> do
path <- writeOnDrive (tempMediumFile temp) userId (tempMediumAlbum temp)
2014-08-18 01:11:05 +00:00
inAlbumId <- return $ tempMediumAlbum temp
2014-08-13 16:18:35 +00:00
medium <- return $ Medium
(tempMediumTitle temp)
2014-08-18 01:11:05 +00:00
('/' : path)
2014-08-13 16:18:35 +00:00
(tempMediumTime temp)
(tempMediumOwner temp)
(tempMediumDesc temp)
(tempMediumTags temp)
2014-08-18 01:11:05 +00:00
inAlbumId
2014-08-13 22:52:32 +00:00
mId <- runDB $ I.insert medium
2014-08-18 01:11:05 +00:00
inAlbum <- runDB $ getJust inAlbumId
newMediaList <- return $ mId : (albumContent inAlbum)
runDB $ update inAlbumId [AlbumContent =. newMediaList]
2014-08-15 13:47:16 +00:00
setMessage "Image succesfully uploaded"
2014-08-13 16:18:35 +00:00
redirect $ HomeR
_ -> do
2014-08-15 13:47:16 +00:00
setMessage "There was an error uploading the file"
2014-08-13 16:18:35 +00:00
redirect $ UploadR
Nothing -> do
2014-08-15 13:47:16 +00:00
setMessage "You need to be logged in"
2014-08-13 16:18:35 +00:00
redirect $ LoginR
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
ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
msu <- lookupSession "userId"
case msu of -- is anybody logged in
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
presence <- return (userId == ownerId)
case presence of -- is the owner present
True -> do
(dUploadWidget, enctype) <- generateFormPost $ dUploadForm userId albumId
defaultLayout $ do
2014-09-24 21:03:18 +00:00
setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` (albumTitle album))
2014-08-26 02:39:13 +00:00
$(widgetFile "dUpload")
False -> 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
ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
msu <- lookupSession "userId"
case msu of -- is anybody logged in
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
presence <- return (userId == ownerId)
case presence of -- is the logged in user the owner
True -> do
((result, dUploadWidget), enctype) <- runFormPost (dUploadForm userId albumId)
case result of
FormSuccess temp -> do
path <- writeOnDrive (tempMediumFile temp) userId albumId
medium <- return $ Medium
(tempMediumTitle temp)
('/' : path)
(tempMediumTime temp)
(tempMediumOwner temp)
(tempMediumDesc temp)
(tempMediumTags temp)
albumId
mId <- runDB $ insert medium
inAlbum <- runDB $ getJust albumId
newMediaList <- return $ mId : (albumContent inAlbum)
runDB $ update albumId [AlbumContent =. newMediaList]
setMessage "Image successfully uploaded"
redirect $ AlbumR albumId
_ -> do
setMessage "There was an error uploading the file"
redirect $ DirectUploadR albumId
False -> 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
writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FilePath
writeOnDrive file userId albumId = do
2014-08-13 16:18:35 +00:00
filename <- return $ fileName file
2014-08-18 01:09:03 +00:00
path <- return $ "static" </> "data"
2014-09-24 21:03:18 +00:00
</> (T.unpack $ extractKey userId)
</> (T.unpack $ extractKey albumId)
</> (T.unpack filename)
2014-08-13 16:18:35 +00:00
liftIO $ fileMove file path
return path
2014-08-13 20:30:48 +00:00
uploadForm :: UserId -> Form TempMedium
uploadForm userId = renderDivs $ TempMedium
2014-08-13 16:18:35 +00:00
<$> areq textField "Title" Nothing
<*> areq fileField "Select file" Nothing
<*> lift (liftIO getCurrentTime)
2014-08-13 20:30:48 +00:00
<*> pure userId
2014-08-13 16:18:35 +00:00
<*> areq textareaField "Description" Nothing
<*> areq tagField "Enter tags" Nothing
2014-08-13 22:52:32 +00:00
<*> areq (selectField albums) "Album" Nothing
where
-- albums :: GHandler App App (OptionList AlbumId)
albums = do
entities <- runDB $ selectList [AlbumOwner ==. userId] [Desc AlbumTitle]
optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
2014-08-13 16:18:35 +00:00
2014-08-26 02:39:13 +00:00
dUploadForm :: UserId -> AlbumId -> Form TempMedium
dUploadForm userId albumId = renderDivs $ TempMedium
<$> areq textField "Title" Nothing
<*> areq fileField "Select file" Nothing
<*> lift (liftIO getCurrentTime)
<*> pure userId
<*> areq textareaField "Description" Nothing
<*> areq tagField "Enter tags" Nothing
<*> pure albumId