236 lines
9.2 KiB
Haskell
236 lines
9.2 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
|
|
user <- runDB $ getJust userId
|
|
albums <- return $ userAlbums user
|
|
case I.null albums of
|
|
False -> do
|
|
(uploadWidget, enctype) <- generateFormPost (uploadForm userId)
|
|
formLayout $ do
|
|
setTitle "Eidolon :: Upload Medium"
|
|
$(widgetFile "upload")
|
|
True -> do
|
|
setMessage "Please create an album first"
|
|
redirect $ NewAlbumR
|
|
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, width) <- 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)
|
|
width
|
|
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
|
|
formLayout $ 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, width) <- generateThumb path ownerId albumId
|
|
medium <- return $ Medium
|
|
(tempMediumTitle temp)
|
|
('/' : path)
|
|
('/' : thumbPath)
|
|
mime
|
|
(tempMediumTime temp)
|
|
(tempMediumOwner temp)
|
|
(tempMediumDesc temp)
|
|
(tempMediumTags temp)
|
|
width
|
|
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, Int)
|
|
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
|
|
width <- liftIO $ withMagickWandGenesis $ do
|
|
(_ , w) <- magickWand
|
|
readImage w (decodeString path)
|
|
w1 <- getImageWidth w
|
|
h1 <- getImageHeight w
|
|
h2 <- return 230
|
|
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 w2
|
|
return (newPath, width)
|
|
|
|
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
|