nek0/eidolon
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

svg upload now works

Browse source 
but only limited
This commit is contained in:
nek0 2016-11-19 22:13:02 +01:00
parent 08903dc28c
commit 1122e9a756
2 changed files with 45 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

74
Handler/Upload.hs
View file

@ -26,9 +26,12 @@ import qualified System.FilePath as FP
import System.Directory import System.Directory
import Text.Blaze.Internal import Text.Blaze.Internal
import Codec.ImageType import Codec.ImageType
import Codec.Picture import Codec.Picture as P
import Codec.Picture.Metadata as PM import Codec.Picture.Metadata as PM
import Codec.Picture.ScaleDCT import Codec.Picture.ScaleDCT
import Graphics.Rasterific.Svg as SVG
import Graphics.Svg
import Graphics.Text.TrueType
getDirectUploadR :: AlbumId -> Handler Html getDirectUploadR :: AlbumId -> Handler Html
getDirectUploadR albumId = do getDirectUploadR albumId = do
@ -110,7 +113,7 @@ postDirectUploadR albumId = do
redirect HomeR redirect HomeR
else do else do
let justErrNames = map fromJust onlyErrNames let justErrNames = map fromJust onlyErrNames
let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
setMessage msg setMessage msg
redirect HomeR redirect HomeR
_ -> do _ -> do
@ -140,32 +143,36 @@ generateThumbs
-> Handler ThumbsMeta -- ^ Resulting metadata to store -> Handler ThumbsMeta -- ^ Resulting metadata to store
generateThumbs path uId aId = do generateThumbs path uId aId = do
eimg <- liftIO $ readImageWithMetadata path eimg <- liftIO $ readImageWithMetadata path
case eimg of orig <- case eimg of
Left e -> error e Left _ -> do
Right (orig, meta) -> do svg <- liftIO $ loadSvgFile path
let thumbName = FP.takeBaseName path ++ "_thumb.jpg" (img, _) <- liftIO $ renderSvgDocument emptyFontCache Nothing 100 $ fromJust svg
prevName = FP.takeBaseName path ++ "_preview.jpg" return img
pathPrefix = "static" FP.</> "data" FP.</> T.unpack (extractKey uId) FP.</> T.unpack (extractKey aId) Right (img, _) -> do
tPath = pathPrefix FP.</> thumbName return $ convertRGBA8 img
pPath = pathPrefix FP.</> prevName let thumbName = FP.takeBaseName path ++ "_thumb.jpg"
origPix = convertRGBA8 orig prevName = FP.takeBaseName path ++ "_preview.jpg"
oWidth = fromIntegral $ fromJust $ PM.lookup Width meta :: Int pathPrefix = "static" FP.</> "data" FP.</> T.unpack (extractKey uId) FP.</> T.unpack (extractKey aId)
oHeight = fromIntegral $ fromJust $ PM.lookup Height meta :: Int tPath = pathPrefix FP.</> thumbName
tWidth = floor (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double) pPath = pathPrefix FP.</> prevName
tHeight = 230 :: Int -- origPix = convertRGBA8 orig
pHeight = 600 :: Int oWidth = P.imageWidth orig :: Int
pScale = (fromIntegral pHeight :: Double) / (fromIntegral oHeight :: Double) oHeight = P.imageHeight orig :: Int
pWidth = floor (fromIntegral oWidth * pScale) tWidth = floor (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double)
tPix = scale (tWidth, tHeight) origPix tHeight = 230 :: Int
pPix = scale (pWidth, pHeight) origPix pHeight = 600 :: Int
liftIO $ saveJpgImage 95 tPath $ ImageRGBA8 tPix pScale = (fromIntegral pHeight :: Double) / (fromIntegral oHeight :: Double)
liftIO $ saveJpgImage 95 pPath $ ImageRGBA8 pPix pWidth = floor (fromIntegral oWidth * pScale)
return $ ThumbsMeta tPix = scale (tWidth, tHeight) orig
{ metaThumbPath = tPath pPix = scale (pWidth, pHeight) orig
, metaPreviewPath = pPath liftIO $ saveJpgImage 95 tPath $ ImageRGBA8 tPix
} liftIO $ saveJpgImage 95 pPath $ ImageRGBA8 pPix
return $ ThumbsMeta
{ metaThumbPath = tPath
, metaPreviewPath = pPath
}
checkCVE_2016_3714 :: FP.FilePath -> Text -> IO Bool checkCVE_2016_3714 :: FP.FilePath -> T.Text -> IO Bool
checkCVE_2016_3714 p m = checkCVE_2016_3714 p m =
case m of case m of
"image/jpeg" -> isJpeg p "image/jpeg" -> isJpeg p
@ -184,7 +191,8 @@ 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
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
let filen = show $ (read $ show $ maximum $ albumContent album :: Int) + 1 let [PersistInt64 int] = keyToValues $ maximum $ albumContent album
let filen = show $ fromIntegral int + 1
let ext = FP.takeExtension $ T.unpack $ fileName fil 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 let path = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> filen ++ ext
dde <- liftIO $ doesDirectoryExist $ FP.dropFileName path dde <- liftIO $ doesDirectoryExist $ FP.dropFileName path
@ -205,16 +213,16 @@ dUploadForm userId albumId = FileBulk
<*> aopt textareaField (bfs ("Description" :: T.Text)) Nothing <*> aopt textareaField (bfs ("Description" :: T.Text)) Nothing
<*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing <*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing
<*> pure albumId <*> pure albumId
<* bootstrapSubmit ("Upload" :: BootstrapSubmit Text) <* bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
data FileBulk = FileBulk data FileBulk = FileBulk
{ fileBulkPrefix :: Text { fileBulkPrefix :: T.Text
, fileBulkFiles :: [FileInfo] , fileBulkFiles :: [FileInfo]
, fileBulkTime :: UTCTime , fileBulkTime :: UTCTime
, fileBulkOwner :: UserId , fileBulkOwner :: UserId
, fileBulkDesc :: Maybe Textarea , fileBulkDesc :: Maybe Textarea
, fileBulkTags :: [Text] , fileBulkTags :: [T.Text]
, fileBulkAlbum :: AlbumId , fileBulkAlbum :: AlbumId
} }
@ -249,7 +257,7 @@ bulkUploadForm userId = (\a b c d e f g -> FileBulk b c d e f g a)
<*> pure userId <*> pure userId
<*> aopt textareaField (bfs ("Description" :: T.Text)) Nothing <*> aopt textareaField (bfs ("Description" :: T.Text)) Nothing
<*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing <*> areq tagField (bfs ("Enter tags" :: T.Text)) Nothing
<* bootstrapSubmit ("Upload" :: BootstrapSubmit Text) <* bootstrapSubmit ("Upload" :: BootstrapSubmit T.Text)
where where
albums = do albums = do
allEnts <- runDB $ selectList [] [Desc AlbumTitle] allEnts <- runDB $ selectList [] [Desc AlbumTitle]
@ -316,7 +324,7 @@ postUploadR = do
redirect HomeR redirect HomeR
else do else do
let justErrNames = map fromJust onlyErrNames let justErrNames = map fromJust onlyErrNames
let msg = Content $ Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames
setMessage msg setMessage msg
redirect HomeR redirect HomeR
_ -> do _ -> do

4
eidolon.cabal
View file

@ -123,6 +123,10 @@ library
, JuicyPixels >= 3.2.8 , JuicyPixels >= 3.2.8
, JuicyPixels-scale-dct , JuicyPixels-scale-dct
, classy-prelude-yesod >= 1.0 , classy-prelude-yesod >= 1.0
-- svg stuff
, rasterific-svg
, svg-tree
, FontyFruity
-- for Migrations -- for Migrations
, HDBC , HDBC
, HDBC-postgresql , HDBC-postgresql