version bump with todo

Handler/Upload.hs

@@ -23,9 +23,11 @@ import Data.Maybe
 import qualified Data.Text as T
 import Data.List as L
 import qualified System.FilePath as FP
+import System.Directory
 import Filesystem.Path.CurrentOS
 import Graphics.ImageMagick.MagickWand
 import Text.Blaze.Internal
+import Codec.ImageType
 
 getDirectUploadR :: AlbumId -> Handler Html
 getDirectUploadR albumId = do
@@ -76,10 +78,12 @@ postDirectUploadR albumId = do
                   errNames <- mapM
                     (\(index, file) -> do
                       let mime = fileContentType file
-                      if
-                        mime `elem` acceptedTypes
+                      if mime `elem` acceptedTypes
                         then do
                           path <- writeOnDrive file ownerId albumId
+                          isOk <- liftIO $ checkCVE_2016_3714 path mime
+                          if isOk
+                            then do
                               (thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId albumId
                               tempName <- if
                                 length indFils == 1
@@ -92,6 +96,9 @@ postDirectUploadR albumId = do
                               runDB $ update albumId [AlbumContent =. newMediaList]
                               putIndexES (ESMedium mId medium)
                               return Nothing
+                          else do
+                            liftIO $ removeFile (FP.normalise path)
+                            return $ Just $ fileName file
                         else
                           return $ Just $ fileName file
                       ) indFils
@@ -119,7 +126,11 @@ postDirectUploadR albumId = do
       setMessage "This Album does not exist"
       redirect $ AlbumR albumId
 
-generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler (FP.FilePath, FP.FilePath, Int, Int, Int)
+generateThumb
+  :: FP.FilePath
+  -> UserId
+  -> AlbumId
+  -> Handler (FP.FilePath, FP.FilePath, Int, Int, Int)
 generateThumb path userId albumId = do
   let newName = FP.takeBaseName path ++ "_thumb.jpg"
   let newPath = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> newName
@@ -149,6 +160,21 @@ generateThumb path userId albumId = do
     return (w1, w2, w3)
   return (newPath, prevPath, iWidth, tWidth, pWidth)
 
+checkCVE_2016_3714 :: FP.FilePath -> Text -> IO Bool
+checkCVE_2016_3714 p m =
+  case m of
+    "image/jpeg"     -> isJpeg p
+    "image/jpg"      -> isJpeg p
+    "image/png"      -> isPng p
+    "image/x-ms-bmp" -> isBmp p
+    "image/x-bmp"    -> isBmp p
+    "image/bmp"      -> isBmp p
+    "image/tiff"     -> isTiff p
+    "image/tiff-fx"  -> isTiff p
+    "image/svg+xml"  -> return True -- TODO: have to check XML for that.
+    "image/gif"      -> isGif p
+    _                -> return False
+
 writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
 writeOnDrive fil userId albumId = do
   --filen <- return $ fileName fil
@@ -238,13 +264,15 @@ postUploadR = do
           errNames <- mapM
             (\(index, file) -> do
               let mime = fileContentType file
-              if
-                mime `elem` acceptedTypes
+              if mime `elem` acceptedTypes
                 then do
                   let inAlbumId = fileBulkAlbum temp
                   albRef <- runDB $ getJust inAlbumId
                   let ownerId = albumOwner albRef
                   path <- writeOnDrive file ownerId inAlbumId
+                  isOk <- liftIO $ checkCVE_2016_3714 path mime
+                  if isOk
+                    then do
                       (thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId inAlbumId
                       tempName <- if
                         length indFils == 1
@@ -257,6 +285,9 @@ postUploadR = do
                       runDB $ update inAlbumId [AlbumContent =. newMediaList]
                       putIndexES (ESMedium mId medium)
                       return Nothing
+                    else do
+                      liftIO $ removeFile (FP.normalise path)
+                      return $ Just $ fileName file
                 else
                   return $ Just $ fileName file
               ) indFils

eidolon.cabal

@@ -1,5 +1,5 @@
 name:                eidolon
-version:             0.0.5
+version:             0.0.6
 synopsis:            Image gallery in Yesod
 homepage:            https://eidolon.nek0.eu
 license:             AGPL-3
@@ -117,6 +117,7 @@ library
                  , unix                          >= 2.7
                  , bloodhound                    >= 0.8
                  , http-types
+                 , image-type
                  -- for Migrations
                  , HDBC
                  , HDBC-postgresql

stack.yaml

@@ -107,6 +107,7 @@ extra-deps:
 - http-date-0.0.6.1
 - http-types-0.9
 - http2-1.3.1
+- image-type-0.1.0.0
 - imagemagick-0.0.4.1
 - iproute-1.7.0
 - kan-extensions-4.2.3