eidolon/Handler/Upload.hs
2014-12-28 07:12:25 +01:00

227 lines
8.8 KiB
Haskell

module Handler.Upload where
import Import as I
import Data.Time
import Data.Maybe
import qualified Data.Text as T
import qualified System.FilePath as FP
import Filesystem.Path.CurrentOS
import Graphics.ImageMagick.MagickWand
data TempMedium = TempMedium
{ tempMediumTitle :: Text
, tempMediumFile :: FileInfo
, tempMediumTime :: UTCTime
, tempMediumOwner :: UserId
, tempMediumDesc :: Textarea
, tempMediumTags :: [Text]
, tempMediumAlbum :: AlbumId
}
getUploadR :: Handler Html
getUploadR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
(uploadWidget, enctype) <- generateFormPost (uploadForm userId)
defaultLayout $ do
setTitle "Eidolon :: Upload Medium"
$(widgetFile "upload")
Nothing -> do
setMessage "You need to be logged in"
redirect $ LoginR
postUploadR :: Handler Html
postUploadR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- lift $ pure $ getUserIdFromText tempUserId
((result, _), _) <- runFormPost (uploadForm userId)
case result of
FormSuccess temp -> do
fil <- return $ tempMediumFile temp
mime <- return $ (fileContentType fil)
case mime `elem` acceptedTypes of
True -> do
albRef <- runDB $ getJust (tempMediumAlbum temp)
ownerId <- return $ albumOwner albRef
path <- writeOnDrive fil ownerId (tempMediumAlbum temp)
thumbPath <- generateThumb path ownerId (tempMediumAlbum temp)
inAlbumId <- return $ tempMediumAlbum temp
medium <- return $ Medium
(tempMediumTitle temp)
('/' : path)
('/' : thumbPath)
mime
(tempMediumTime temp)
(tempMediumOwner temp)
(tempMediumDesc temp)
(tempMediumTags temp)
inAlbumId
mId <- runDB $ I.insert medium
inAlbum <- runDB $ getJust inAlbumId
newMediaList <- return $ mId : (albumContent inAlbum)
runDB $ update inAlbumId [AlbumContent =. newMediaList]
setMessage "Image succesfully uploaded"
redirect $ HomeR
_ -> do
setMessage "This filetype is not supported"
redirect $ UploadR
_ -> do
setMessage "There was an error uploading the file"
redirect $ UploadR
Nothing -> do
setMessage "You need to be logged in"
redirect $ LoginR
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
msu <- lookupSession "userId"
case msu of -- is anybody logged in
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album))
case presence of -- is the owner present or a user with whom the album is shared
True -> do
(dUploadWidget, enctype) <- generateFormPost $ dUploadForm userId albumId
defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` (albumTitle album))
$(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
msu <- lookupSession "userId"
case msu of -- is anybody logged in
Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId
presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album))
case presence of -- is the logged in user the owner or is the album shared with him
True -> do
((result, _), _) <- runFormPost (dUploadForm userId albumId)
case result of
FormSuccess temp -> do
fil <- return $ tempMediumFile temp
mime <- return $ fileContentType fil
case mime `elem` acceptedTypes of
True -> do
albRef <- runDB $ getJust (tempMediumAlbum temp)
refOwnerId <- return $ albumOwner albRef
path <- writeOnDrive fil refOwnerId albumId
thumbPath <- generateThumb path ownerId albumId
medium <- return $ Medium
(tempMediumTitle temp)
('/' : path)
('/' : thumbPath)
mime
(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 "This filetype is not supported"
redirect $ DirectUploadR 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
generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler FP.FilePath
generateThumb path userId albumId = do
newName <- return $ (FP.takeBaseName path) ++ "_thumb" ++ (FP.takeExtension path)
newPath <- return $ "static" FP.</> "data"
FP.</> (T.unpack $ extractKey userId)
FP.</> (T.unpack $ extractKey albumId)
FP.</> newName
liftIO $ withMagickWandGenesis $ do
(_ , w) <- magickWand
readImage w (decodeString path)
w1 <- getImageWidth w
h1 <- getImageHeight w
h2 <- return 220
w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2) :: Double)
resizeImage w w2 h2 lanczosFilter 1
setImageCompressionQuality w 95
writeImage w (Just (decodeString newPath))
return newPath
writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
writeOnDrive fil userId albumId = do
--filen <- return $ fileName fil
album <- runDB $ getJust albumId
filen <- return $ show $ (length $ albumContent album) + 1
ext <- return $ FP.takeExtension $ T.unpack $ fileName fil
path <- return $ "static" FP.</> "data"
FP.</> (T.unpack $ extractKey userId)
FP.</> (T.unpack $ extractKey albumId)
FP.</> filen ++ ext
liftIO $ fileMove fil path
return path
uploadForm :: UserId -> Form TempMedium
uploadForm userId = renderDivs $ (\a b c d e f g -> TempMedium b c d e f g a)
<$> areq (selectField albums) "Album" Nothing
<*> areq textField "Title" Nothing
<*> areq fileField "Select file" Nothing
<*> lift (liftIO getCurrentTime)
<*> pure userId
<*> areq textareaField "Description" Nothing
<*> areq tagField "Enter tags" Nothing
where
-- albums :: GHandler App App (OptionList AlbumId)
albums = do
allEnts <- runDB $ selectList [] [Desc AlbumTitle]
entities <- return $
map fromJust $
removeItem Nothing $ map
(\ent -> do
case (userId == (albumOwner $ entityVal ent)) || (userId `elem` (albumShares $ entityVal ent)) of
True -> Just ent
False -> Nothing
) allEnts
-- entities <- runDB $ selectList [AlbumOwner ==. userId] [Desc AlbumTitle]
optionsPairs $ I.map (\alb -> (albumTitle $ entityVal alb, entityKey alb)) entities
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