restricting uploadable filetypes

This commit is contained in:
nek0 2014-12-03 22:01:57 +01:00
parent 90182768f1
commit 485fe73fde
2 changed files with 52 additions and 35 deletions

View file

@ -11,6 +11,7 @@ import Control.Monad.Trans.Resource
import Foreign import Foreign
import Foreign.C.Types import Foreign.C.Types
import Foreign.C.String import Foreign.C.String
import Helper
data TempMedium = TempMedium data TempMedium = TempMedium
{ tempMediumTitle :: Text { tempMediumTitle :: Text
@ -45,24 +46,30 @@ postUploadR = do
((result, uploadWidget), enctype) <- runFormPost (uploadForm userId) ((result, uploadWidget), enctype) <- runFormPost (uploadForm userId)
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
path <- writeOnDrive (tempMediumFile temp) userId (tempMediumAlbum temp) fil <- return $ tempMediumFile temp
thumbPath <- generateThumb path userId (tempMediumAlbum temp) case (fileContentType fil) `elem` acceptedTypes of
inAlbumId <- return $ tempMediumAlbum temp True -> do
medium <- return $ Medium path <- writeOnDrive fil userId (tempMediumAlbum temp)
(tempMediumTitle temp) thumbPath <- generateThumb path userId (tempMediumAlbum temp)
('/' : path) inAlbumId <- return $ tempMediumAlbum temp
('/' : thumbPath) medium <- return $ Medium
(tempMediumTime temp) (tempMediumTitle temp)
(tempMediumOwner temp) ('/' : path)
(tempMediumDesc temp) ('/' : thumbPath)
(tempMediumTags temp) (tempMediumTime temp)
inAlbumId (tempMediumOwner temp)
mId <- runDB $ I.insert medium (tempMediumDesc temp)
inAlbum <- runDB $ getJust inAlbumId (tempMediumTags temp)
newMediaList <- return $ mId : (albumContent inAlbum) inAlbumId
runDB $ update inAlbumId [AlbumContent =. newMediaList] mId <- runDB $ I.insert medium
setMessage "Image succesfully uploaded" inAlbum <- runDB $ getJust inAlbumId
redirect $ HomeR 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 _ -> do
setMessage "There was an error uploading the file" setMessage "There was an error uploading the file"
redirect $ UploadR redirect $ UploadR
@ -117,23 +124,29 @@ postDirectUploadR albumId = do
((result, dUploadWidget), enctype) <- runFormPost (dUploadForm userId albumId) ((result, dUploadWidget), enctype) <- runFormPost (dUploadForm userId albumId)
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
path <- writeOnDrive (tempMediumFile temp) userId albumId fil <- return $ tempMediumFile temp
thumbPath <- generateThumb path ownerId albumId case (fileContentType fil) `elem` acceptedTypes of
medium <- return $ Medium True -> do
(tempMediumTitle temp) path <- writeOnDrive fil userId albumId
('/' : path) thumbPath <- generateThumb path ownerId albumId
('/' : thumbPath) medium <- return $ Medium
(tempMediumTime temp) (tempMediumTitle temp)
(tempMediumOwner temp) ('/' : path)
(tempMediumDesc temp) ('/' : thumbPath)
(tempMediumTags temp) (tempMediumTime temp)
albumId (tempMediumOwner temp)
mId <- runDB $ insert medium (tempMediumDesc temp)
inAlbum <- runDB $ getJust albumId (tempMediumTags temp)
newMediaList <- return $ mId : (albumContent inAlbum) albumId
runDB $ update albumId [AlbumContent =. newMediaList] mId <- runDB $ insert medium
setMessage "Image successfully uploaded" inAlbum <- runDB $ getJust albumId
redirect $ AlbumR 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 _ -> do
setMessage "There was an error uploading the file" setMessage "There was an error uploading the file"
redirect $ DirectUploadR albumId redirect $ DirectUploadR albumId

View file

@ -11,6 +11,7 @@ module Helper
, sendMail , sendMail
, generateString , generateString
, removeItem , removeItem
, acceptedTypes
) )
where where
@ -117,3 +118,6 @@ removeItem _ [] = []
removeItem x (y:ys) removeItem x (y:ys)
| x == y = removeItem x ys | x == y = removeItem x ys
| otherwise = y : removeItem x ys | otherwise = y : removeItem x ys
acceptedTypes :: [T.Text]
acceptedTypes = ["image/jpeg", "image/png", "image/x-ms-bmp", "image/x-bmp", "image/bmp", "image/tiff", "image/tiff-fx"]