restricting uploadable filetypes

Handler/Upload.hs

@@ -11,6 +11,7 @@ import Control.Monad.Trans.Resource
 import Foreign
 import Foreign.C.Types
 import Foreign.C.String
+import Helper
 
 data TempMedium = TempMedium
   { tempMediumTitle :: Text
@@ -45,7 +46,10 @@ postUploadR = do
       ((result, uploadWidget), enctype) <- runFormPost (uploadForm userId)
       case result of
         FormSuccess temp -> do
-          path <- writeOnDrive (tempMediumFile temp) userId (tempMediumAlbum temp)
+          fil <- return $ tempMediumFile temp
+          case (fileContentType fil) `elem` acceptedTypes of
+            True -> do
+              path <- writeOnDrive fil userId (tempMediumAlbum temp)
               thumbPath <- generateThumb path userId (tempMediumAlbum temp)
               inAlbumId <- return $ tempMediumAlbum temp
               medium <- return $ Medium
@@ -63,6 +67,9 @@ postUploadR = do
               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
@@ -117,7 +124,10 @@ postDirectUploadR albumId = do
               ((result, dUploadWidget), enctype) <- runFormPost (dUploadForm userId albumId)
               case result of
                 FormSuccess temp -> do
-                  path <- writeOnDrive (tempMediumFile temp) userId albumId
+                  fil <- return $ tempMediumFile temp
+                  case (fileContentType fil) `elem` acceptedTypes of
+                    True -> do
+                      path <- writeOnDrive fil userId albumId
                       thumbPath <- generateThumb path ownerId albumId
                       medium <- return $ Medium
                         (tempMediumTitle temp)
@@ -134,6 +144,9 @@ postDirectUploadR albumId = do
                       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

Helper.hs

@@ -11,6 +11,7 @@ module Helper
   , sendMail
   , generateString
   , removeItem
+  , acceptedTypes
   )
 where
 
@@ -117,3 +118,6 @@ removeItem _ [] = []
 removeItem x (y:ys)
   | x == 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"]