version bump with todo
This commit is contained in:
nek0
parent
6fb658d5fb
commit
eaa80952a6
3 changed files with 63 additions and 30 deletions
|
|
@ -23,9 +23,11 @@ import Data.Maybe
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.List as L
|
import Data.List as L
|
||||||
import qualified System.FilePath as FP
|
import qualified System.FilePath as FP
|
||||||
|
import System.Directory
|
||||||
import Filesystem.Path.CurrentOS
|
import Filesystem.Path.CurrentOS
|
||||||
import Graphics.ImageMagick.MagickWand
|
import Graphics.ImageMagick.MagickWand
|
||||||
import Text.Blaze.Internal
|
import Text.Blaze.Internal
|
||||||
|
import Codec.ImageType
|
||||||
|
|
||||||
getDirectUploadR :: AlbumId -> Handler Html
|
getDirectUploadR :: AlbumId -> Handler Html
|
||||||
getDirectUploadR albumId = do
|
getDirectUploadR albumId = do
|
||||||
|
|
@ -76,22 +78,27 @@ postDirectUploadR albumId = do
|
||||||
errNames <- mapM
|
errNames <- mapM
|
||||||
(\(index, file) -> do
|
(\(index, file) -> do
|
||||||
let mime = fileContentType file
|
let mime = fileContentType file
|
||||||
if
|
if mime `elem` acceptedTypes
|
||||||
mime `elem` acceptedTypes
|
|
||||||
then do
|
then do
|
||||||
path <- writeOnDrive file ownerId albumId
|
path <- writeOnDrive file ownerId albumId
|
||||||
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId albumId
|
isOk <- liftIO $ checkCVE_2016_3714 path mime
|
||||||
tempName <- if
|
if isOk
|
||||||
length indFils == 1
|
then do
|
||||||
then return $ fileBulkPrefix temp
|
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId albumId
|
||||||
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
|
tempName <- if
|
||||||
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth albumId ('/' : prevPath) pWidth
|
length indFils == 1
|
||||||
mId <- runDB $ I.insert medium
|
then return $ fileBulkPrefix temp
|
||||||
inALbum <- runDB $ getJust albumId
|
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
|
||||||
let newMediaList = mId : albumContent inALbum
|
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth albumId ('/' : prevPath) pWidth
|
||||||
runDB $ update albumId [AlbumContent =. newMediaList]
|
mId <- runDB $ I.insert medium
|
||||||
putIndexES (ESMedium mId medium)
|
inALbum <- runDB $ getJust albumId
|
||||||
return Nothing
|
let newMediaList = mId : albumContent inALbum
|
||||||
|
runDB $ update albumId [AlbumContent =. newMediaList]
|
||||||
|
putIndexES (ESMedium mId medium)
|
||||||
|
return Nothing
|
||||||
|
else do
|
||||||
|
liftIO $ removeFile (FP.normalise path)
|
||||||
|
return $ Just $ fileName file
|
||||||
else
|
else
|
||||||
return $ Just $ fileName file
|
return $ Just $ fileName file
|
||||||
) indFils
|
) indFils
|
||||||
|
|
@ -119,7 +126,11 @@ postDirectUploadR albumId = do
|
||||||
setMessage "This Album does not exist"
|
setMessage "This Album does not exist"
|
||||||
redirect $ AlbumR albumId
|
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
|
generateThumb path userId albumId = do
|
||||||
let newName = FP.takeBaseName path ++ "_thumb.jpg"
|
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 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 (w1, w2, w3)
|
||||||
return (newPath, prevPath, iWidth, tWidth, pWidth)
|
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 :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
|
||||||
writeOnDrive fil userId albumId = do
|
writeOnDrive fil userId albumId = do
|
||||||
--filen <- return $ fileName fil
|
--filen <- return $ fileName fil
|
||||||
|
|
@ -238,25 +264,30 @@ postUploadR = do
|
||||||
errNames <- mapM
|
errNames <- mapM
|
||||||
(\(index, file) -> do
|
(\(index, file) -> do
|
||||||
let mime = fileContentType file
|
let mime = fileContentType file
|
||||||
if
|
if mime `elem` acceptedTypes
|
||||||
mime `elem` acceptedTypes
|
|
||||||
then do
|
then do
|
||||||
let inAlbumId = fileBulkAlbum temp
|
let inAlbumId = fileBulkAlbum temp
|
||||||
albRef <- runDB $ getJust inAlbumId
|
albRef <- runDB $ getJust inAlbumId
|
||||||
let ownerId = albumOwner albRef
|
let ownerId = albumOwner albRef
|
||||||
path <- writeOnDrive file ownerId inAlbumId
|
path <- writeOnDrive file ownerId inAlbumId
|
||||||
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId inAlbumId
|
isOk <- liftIO $ checkCVE_2016_3714 path mime
|
||||||
tempName <- if
|
if isOk
|
||||||
length indFils == 1
|
then do
|
||||||
then return $ fileBulkPrefix temp
|
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId inAlbumId
|
||||||
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
|
tempName <- if
|
||||||
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth inAlbumId ('/' : prevPath) pWidth
|
length indFils == 1
|
||||||
mId <- runDB $ I.insert medium
|
then return $ fileBulkPrefix temp
|
||||||
inALbum <- runDB $ getJust inAlbumId
|
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
|
||||||
let newMediaList = mId : albumContent inALbum
|
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth inAlbumId ('/' : prevPath) pWidth
|
||||||
runDB $ update inAlbumId [AlbumContent =. newMediaList]
|
mId <- runDB $ I.insert medium
|
||||||
putIndexES (ESMedium mId medium)
|
inALbum <- runDB $ getJust inAlbumId
|
||||||
return Nothing
|
let newMediaList = mId : albumContent inALbum
|
||||||
|
runDB $ update inAlbumId [AlbumContent =. newMediaList]
|
||||||
|
putIndexES (ESMedium mId medium)
|
||||||
|
return Nothing
|
||||||
|
else do
|
||||||
|
liftIO $ removeFile (FP.normalise path)
|
||||||
|
return $ Just $ fileName file
|
||||||
else
|
else
|
||||||
return $ Just $ fileName file
|
return $ Just $ fileName file
|
||||||
) indFils
|
) indFils
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
name: eidolon
|
name: eidolon
|
||||||
version: 0.0.5
|
version: 0.0.6
|
||||||
synopsis: Image gallery in Yesod
|
synopsis: Image gallery in Yesod
|
||||||
homepage: https://eidolon.nek0.eu
|
homepage: https://eidolon.nek0.eu
|
||||||
license: AGPL-3
|
license: AGPL-3
|
||||||
|
|
@ -117,6 +117,7 @@ library
|
||||||
, unix >= 2.7
|
, unix >= 2.7
|
||||||
, bloodhound >= 0.8
|
, bloodhound >= 0.8
|
||||||
, http-types
|
, http-types
|
||||||
|
, image-type
|
||||||
-- for Migrations
|
-- for Migrations
|
||||||
, HDBC
|
, HDBC
|
||||||
, HDBC-postgresql
|
, HDBC-postgresql
|
||||||
|
|
|
||||||
|
|
@ -107,6 +107,7 @@ extra-deps:
|
||||||
- http-date-0.0.6.1
|
- http-date-0.0.6.1
|
||||||
- http-types-0.9
|
- http-types-0.9
|
||||||
- http2-1.3.1
|
- http2-1.3.1
|
||||||
|
- image-type-0.1.0.0
|
||||||
- imagemagick-0.0.4.1
|
- imagemagick-0.0.4.1
|
||||||
- iproute-1.7.0
|
- iproute-1.7.0
|
||||||
- kan-extensions-4.2.3
|
- kan-extensions-4.2.3
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue