eidolon/Handler/Upload.hs

275 lines
11 KiB
Haskell
Raw 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 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
import Filesystem.Path.CurrentOS
import Graphics.ImageMagick.MagickWand
2015-01-16 00:23:02 +00:00
import Text.Blaze.Internal
2014-08-13 16:18:35 +00:00
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
2014-08-26 02:39:13 +00:00
msu <- lookupSession "userId"
case msu of -- is anybody logged in
Just tempUserId -> do
2015-09-14 16:54:46 +00:00
let userId = getUserIdFromText tempUserId
if
userId == ownerId || userId `elem` albumShares album
-- is the owner present or a user with whom the album is shared
then do
2014-08-26 02:39:13 +00:00
(dUploadWidget, enctype) <- generateFormPost $ dUploadForm userId albumId
formLayout $ 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"
2015-09-14 16:54:46 +00:00
redirect 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
2014-08-26 02:39:13 +00:00
msu <- lookupSession "userId"
case msu of -- is anybody logged in
Just tempUserId -> do
2015-09-14 16:54:46 +00:00
let userId = getUserIdFromText tempUserId
if
userId == ownerId || userId `elem` albumShares album
-- is the logged in user the owner or is the album shared with him
then do
2014-12-28 06:12:25 +00:00
((result, _), _) <- runFormPost (dUploadForm userId albumId)
2014-08-26 02:39:13 +00:00
case result of
FormSuccess temp -> do
2015-09-14 16:54:46 +00:00
let fils = fileBulkFiles temp
let indFils = zip [1..] fils
2015-01-16 00:23:02 +00:00
errNames <- mapM
(\(index, file) -> do
2015-09-14 16:54:46 +00:00
let mime = fileContentType file
if
mime `elem` acceptedTypes
then do
2015-01-16 00:23:02 +00:00
path <- writeOnDrive file ownerId albumId
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId albumId
2015-09-14 16:54:46 +00:00
tempName <- if
length indFils == 1
then return $ fileBulkPrefix temp
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth albumId ('/' : prevPath) pWidth
2015-01-16 00:23:02 +00:00
mId <- runDB $ I.insert medium
inALbum <- runDB $ getJust albumId
2015-09-14 16:54:46 +00:00
let newMediaList = mId : albumContent inALbum
2015-01-16 00:23:02 +00:00
runDB $ update albumId [AlbumContent =. newMediaList]
return Nothing
2015-09-14 16:54:46 +00:00
else
2015-01-16 00:23:02 +00:00
return $ Just $ fileName file
) indFils
2015-09-14 16:54:46 +00:00
let onlyErrNames = removeItem Nothing errNames
if
L.null onlyErrNames
then do
2015-01-16 00:23:02 +00:00
setMessage "All images succesfully uploaded"
2015-09-14 16:54:46 +00:00
redirect HomeR
else do
let justErrNames = map fromJust onlyErrNames
let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
2015-01-16 00:23:02 +00:00
setMessage msg
2015-09-14 16:54:46 +00:00
redirect HomeR
2014-08-26 02:39:13 +00:00
_ -> do
setMessage "There was an error uploading the file"
redirect $ DirectUploadR albumId
2015-09-14 16:54:46 +00:00
else do -- owner is not present
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"
redirect $ AlbumR albumId
Nothing -> do
setMessage "This Album does not exist"
redirect $ AlbumR albumId
generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler (FP.FilePath, FP.FilePath, Int, Int, Int)
2014-10-01 22:58:36 +00:00
generateThumb path userId albumId = do
2015-09-14 16:54:46 +00:00
let newName = FP.takeBaseName path ++ "_thumb.jpg"
let newPath = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> newName
let prevName = FP.takeBaseName path ++ "_preview.jpg"
let prevPath = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> prevName
(iWidth, tWidth, pWidth) <- liftIO $ withMagickWandGenesis $ do
(_, w) <- magickWand
(_, p) <- magickWand
2014-12-02 07:02:40 +00:00
readImage w (decodeString path)
readImage p (decodeString path)
2014-12-02 07:02:40 +00:00
w1 <- getImageWidth w
h1 <- getImageHeight w
2015-09-14 16:54:46 +00:00
let h2 = 230
let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double)
let h3 = h1 `div` 2
let w3 = w1 `div` 2
2015-08-19 23:42:17 +00:00
setImageAlphaChannel w deactivateAlphaChannel
setImageAlphaChannel p deactivateAlphaChannel
2015-08-19 23:42:17 +00:00
setImageFormat w "jpeg"
setImageFormat p "jpeg"
2014-12-02 07:02:40 +00:00
resizeImage w w2 h2 lanczosFilter 1
resizeImage p w3 h3 lanczosFilter 1
2014-12-02 07:02:40 +00:00
setImageCompressionQuality w 95
setImageCompressionQuality p 95
2014-12-02 07:02:40 +00:00
writeImage w (Just (decodeString newPath))
writeImage p (Just (decodeString prevPath))
return (w1, w2, w3)
return (newPath, prevPath, iWidth, tWidth, pWidth)
2014-10-01 22:58:36 +00:00
2014-12-02 07:02:40 +00:00
writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
writeOnDrive fil userId albumId = do
2014-12-03 22:30:13 +00:00
--filen <- return $ fileName fil
album <- runDB $ getJust albumId
2015-09-14 16:54:46 +00:00
let filen = show $ length (albumContent album) + 1
let ext = FP.takeExtension $ T.unpack $ fileName fil
let path = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> filen ++ ext
2014-12-02 07:02:40 +00:00
liftIO $ fileMove fil path
2014-08-13 16:18:35 +00:00
return path
2015-01-16 00:23:02 +00:00
dUploadForm :: UserId -> AlbumId -> Form FileBulk
dUploadForm userId albumId = renderDivs $ FileBulk
<$> areq textField "Title" Nothing
<*> areq multiFileField "Select file(s)" Nothing
<*> lift (liftIO getCurrentTime)
<*> pure userId
<*> aopt textareaField "Description" Nothing
2015-01-16 00:23:02 +00:00
<*> areq tagField "Enter tags" Nothing
<*> pure albumId
data FileBulk = FileBulk
{ fileBulkPrefix :: Text
, fileBulkFiles :: [FileInfo]
, fileBulkTime :: UTCTime
, fileBulkOwner :: UserId
, fileBulkDesc :: Maybe Textarea
2015-01-16 00:23:02 +00:00
, fileBulkTags :: [Text]
, fileBulkAlbum :: AlbumId
}
getUploadR :: Handler Html
getUploadR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
2015-09-14 16:54:46 +00:00
let userId = getUserIdFromText tempUserId
2015-01-16 00:23:02 +00:00
user <- runDB $ getJust userId
2015-09-14 16:54:46 +00:00
let albums = userAlbums user
if
I.null albums
then do
2015-01-16 00:23:02 +00:00
(uploadWidget, enctype) <- generateFormPost (bulkUploadForm userId)
formLayout $ do
setTitle "Eidolon :: Upload Medium"
$(widgetFile "bulkUpload")
2015-09-14 16:54:46 +00:00
else do
2015-01-16 00:23:02 +00:00
setMessage "Please create an album first"
2015-09-14 16:54:46 +00:00
redirect NewAlbumR
2015-01-16 00:23:02 +00:00
Nothing -> do
setMessage "You need to be logged in"
2015-09-14 16:54:46 +00:00
redirect LoginR
2015-01-16 00:23:02 +00:00
bulkUploadForm :: UserId -> Form FileBulk
bulkUploadForm userId = renderDivs $ (\a b c d e f g -> FileBulk b c d e f g a)
<$> areq (selectField albums) "Album" Nothing
<*> areq textField "Title" 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 textareaField "Description" Nothing
2014-08-13 16:18:35 +00:00
<*> areq tagField "Enter tags" Nothing
2014-08-13 22:52:32 +00:00
where
albums = do
allEnts <- runDB $ selectList [] [Desc AlbumTitle]
2015-09-14 16:54:46 +00:00
let entities = map fromJust $ removeItem Nothing $ map (\ent ->
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
2014-08-13 16:18:35 +00:00
2015-01-16 00:23:02 +00:00
postUploadR :: Handler Html
postUploadR = do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
2015-09-14 16:54:46 +00:00
let userId = getUserIdFromText tempUserId
2015-01-16 00:23:02 +00:00
((result, _), _) <- runFormPost (bulkUploadForm userId)
case result of
FormSuccess temp -> do
2015-09-14 16:54:46 +00:00
let fils = fileBulkFiles temp
let indFils = zip [1..] fils
2015-01-16 00:23:02 +00:00
errNames <- mapM
(\(index, file) -> do
2015-09-14 16:54:46 +00:00
let mime = fileContentType file
if
mime `elem` acceptedTypes
then do
let inAlbumId = fileBulkAlbum temp
2015-01-16 00:23:02 +00:00
albRef <- runDB $ getJust inAlbumId
2015-09-14 16:54:46 +00:00
let ownerId = albumOwner albRef
2015-01-16 00:23:02 +00:00
path <- writeOnDrive file ownerId inAlbumId
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId inAlbumId
2015-09-14 16:54:46 +00:00
tempName <- if
length indFils == 1
then return $ fileBulkPrefix temp
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth inAlbumId ('/' : prevPath) pWidth
2015-01-16 00:23:02 +00:00
mId <- runDB $ I.insert medium
inALbum <- runDB $ getJust inAlbumId
2015-09-14 16:54:46 +00:00
let newMediaList = mId : albumContent inALbum
2015-01-16 00:23:02 +00:00
runDB $ update inAlbumId [AlbumContent =. newMediaList]
return Nothing
2015-09-14 16:54:46 +00:00
else
2015-01-16 00:23:02 +00:00
return $ Just $ fileName file
) indFils
2015-09-14 16:54:46 +00:00
let onlyErrNames = removeItem Nothing errNames
if
L.null onlyErrNames
then do
2015-01-16 00:23:02 +00:00
setMessage "All images succesfully uploaded"
2015-09-14 16:54:46 +00:00
redirect HomeR
else do
let justErrNames = map fromJust onlyErrNames
let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
2015-01-16 00:23:02 +00:00
setMessage msg
2015-09-14 16:54:46 +00:00
redirect HomeR
2015-01-16 00:23:02 +00:00
_ -> do
setMessage "There was an error uploading the file"
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"
2015-09-14 16:54:46 +00:00
redirect LoginR