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

dropping imegamagick for juicypixels

Browse source
This commit is contained in:
nek0 2016-05-07 21:23:03 +02:00
parent eaa80952a6
commit dce81ef161
3 changed files with 79 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

101
Handler/Upload.hs
View file

@ -24,10 +24,11 @@ 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 System.Directory
import Filesystem.Path.CurrentOS
import Graphics.ImageMagick.MagickWand
import Text.Blaze.Internal import Text.Blaze.Internal
import Codec.ImageType import Codec.ImageType
import Codec.Picture
import Codec.Picture.Metadata as PM
import Codec.Picture.ScaleDCT
getDirectUploadR :: AlbumId -> Handler Html getDirectUploadR :: AlbumId -> Handler Html
getDirectUploadR albumId = do getDirectUploadR albumId = do
@ -84,12 +85,11 @@ postDirectUploadR albumId = do
isOk <- liftIO $ checkCVE_2016_3714 path mime isOk <- liftIO $ checkCVE_2016_3714 path mime
if isOk if isOk
then do then do
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId albumId meta <- generateThumbs path ownerId albumId
tempName <- if tempName <- if length indFils == 1
length indFils == 1
then return $ fileBulkPrefix temp then return $ fileBulkPrefix temp
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils))) else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils)))
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth albumId ('/' : prevPath) pWidth let medium = Medium tempName ('/' : path) ('/' : metaThumbPath meta) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) (metaImageWidth meta) (metaThumbWidth meta) albumId ('/' : metaPreviewPath meta) (metaPreviewWidth meta)
mId <- runDB $ I.insert medium mId <- runDB $ I.insert medium
inALbum <- runDB $ getJust albumId inALbum <- runDB $ getJust albumId
let newMediaList = mId : albumContent inALbum let newMediaList = mId : albumContent inALbum
@ -126,39 +126,50 @@ postDirectUploadR albumId = do
setMessage "This Album does not exist" setMessage "This Album does not exist"
redirect $ AlbumR albumId redirect $ AlbumR albumId
generateThumb -- | Type to pass metadata about imgaes around.
:: FP.FilePath data ThumbsMeta = ThumbsMeta
-> UserId { metaThumbPath :: FP.FilePath -- ^ Filepath of the new thumbnail image
-> AlbumId , metaPreviewPath :: FP.FilePath -- ^ Filepath of the new preview image
-> Handler (FP.FilePath, FP.FilePath, Int, Int, Int) , metaImageWidth :: Int -- ^ Width of the original image
generateThumb path userId albumId = do , metaThumbWidth :: Int -- ^ Width of the generated thumbnail image
let newName = FP.takeBaseName path ++ "_thumb.jpg" , metaPreviewWidth :: Int -- ^ Width of the generated preview image
let newPath = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> newName }
let prevName = FP.takeBaseName path ++ "_preview.jpg"
let prevPath = "static" FP.</> "data" FP.</> T.unpack (extractKey userId) FP.</> T.unpack (extractKey albumId) FP.</> prevName -- | generate thumbnail and preview images from uploaded image
(iWidth, tWidth, pWidth) <- liftIO $ withMagickWandGenesis $ do generateThumbs
(_, w) <- magickWand :: FP.FilePath -- ^ Path to original image
(_, p) <- magickWand -> UserId -- ^ Uploading user
readImage w (T.pack path) -> AlbumId -- ^ Destination album
readImage p (T.pack path) -> Handler ThumbsMeta -- ^ Resulting metadata to store
w1 <- getImageWidth w generateThumbs path uId aId = do
h1 <- getImageHeight w eimg <- liftIO $ readImageWithMetadata path
let h2 = 230 case eimg of
let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double) Left e -> error e
let w3 = 1380 Right (orig, meta) -> do
let h3 = floor (fromIntegral h1 / fromIntegral w1 * fromIntegral w3 :: Double) let thumbName = FP.takeBaseName path ++ "_thumb.jpg"
setImageAlphaChannel w deactivateAlphaChannel prevName = FP.takeBaseName path ++ "_preview.jpg"
setImageAlphaChannel p deactivateAlphaChannel pathPrefix = "static" FP.</> "data" FP.</> T.unpack (extractKey uId) FP.</> T.unpack (extractKey aId)
setImageFormat w "jpeg" tPath = pathPrefix FP.</> thumbName
setImageFormat p "jpeg" pPath = pathPrefix FP.</> prevName
resizeImage w w2 h2 lanczosFilter 1 origPix = convertRGBA8 orig
resizeImage p w3 h3 lanczosFilter 1 oWidth = fromIntegral $ fromJust $ PM.lookup Width meta :: Int
setImageCompressionQuality w 95 oHeight = fromIntegral $ fromJust $ PM.lookup Height meta :: Int
setImageCompressionQuality p 95 tWidth = floor (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double)
writeImage w (Just (T.pack newPath)) tHeight = 230 :: Int
writeImage p (Just (T.pack prevPath)) pWidth = 1380 :: Int
return (w1, w2, w3) pScale = (fromIntegral pWidth :: Double) / (fromIntegral oWidth :: Double)
return (newPath, prevPath, iWidth, tWidth, pWidth) pHeight = floor (fromIntegral oHeight * pScale)
tPix = scale (tWidth, tHeight) origPix
pPix = scale (pWidth, pHeight) origPix
liftIO $ saveJpgImage 95 tPath $ ImageRGBA8 tPix
liftIO $ saveJpgImage 95 pPath $ ImageRGBA8 pPix
return $ ThumbsMeta
{ metaThumbPath = tPath
, metaPreviewPath = pPath
, metaImageWidth = oWidth
, metaThumbWidth = tWidth
, metaPreviewWidth = pWidth
}
checkCVE_2016_3714 :: FP.FilePath -> Text -> IO Bool checkCVE_2016_3714 :: FP.FilePath -> Text -> IO Bool
checkCVE_2016_3714 p m = checkCVE_2016_3714 p m =
@ -273,12 +284,18 @@ postUploadR = do
isOk <- liftIO $ checkCVE_2016_3714 path mime isOk <- liftIO $ checkCVE_2016_3714 path mime
if isOk if isOk
then do then do
(thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb path ownerId inAlbumId meta <- generateThumbs path ownerId inAlbumId
tempName <- if tempName <- if
length indFils == 1 length indFils == 1
then return $ fileBulkPrefix temp then return $ fileBulkPrefix temp
else return (fileBulkPrefix temp `T.append` " " `T.append` T.pack (show (index :: Int)) `T.append` " of " `T.append` T.pack (show (length indFils))) else
let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth inAlbumId ('/' : prevPath) pWidth return
(fileBulkPrefix temp `T.append`
" " `T.append`
T.pack (show (index :: Int)) `T.append`
" of " `T.append`
T.pack (show (length indFils)))
let medium = Medium tempName ('/' : path) ('/' : metaThumbPath meta) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) (metaImageWidth meta) (metaThumbWidth meta) inAlbumId ('/' : metaPreviewPath meta) (metaPreviewWidth meta)
mId <- runDB $ I.insert medium mId <- runDB $ I.insert medium
inALbum <- runDB $ getJust inAlbumId inALbum <- runDB $ getJust inAlbumId
let newMediaList = mId : albumContent inALbum let newMediaList = mId : albumContent inALbum

2
eidolon.cabal
View file

@ -118,6 +118,8 @@ library
, bloodhound >= 0.8 , bloodhound >= 0.8
, http-types , http-types
, image-type , image-type
, JuicyPixels >= 3.2.7
, JuicyPixels-scale-dct
-- for Migrations -- for Migrations
, HDBC , HDBC
, HDBC-postgresql , HDBC-postgresql

30
stack.yaml
View file

@ -8,7 +8,8 @@ extra-deps:
- HDBC-postgresql-2.3.2.3 - HDBC-postgresql-2.3.2.3
- HTTP-4000.2.23 - HTTP-4000.2.23
- HUnit-1.3.1.1 - HUnit-1.3.1.1
- JuicyPixels-3.2.6.4 - JuicyPixels-3.2.7
- JuicyPixels-scale-dct-0.1.1.0
- MonadCatchIO-transformers-0.3.1.3 - MonadCatchIO-transformers-0.3.1.3
- QuickCheck-2.8.2 - QuickCheck-2.8.2
- ReadArgs-1.2.2 - ReadArgs-1.2.2
@ -28,7 +29,8 @@ extra-deps:
- attoparsec-0.13.0.1 - attoparsec-0.13.0.1
- authenticate-1.3.2.11 - authenticate-1.3.2.11
- auto-update-0.1.3 - auto-update-0.1.3
- base-orphans-0.5.1 - base-compat-0.9.0
- base-orphans-0.5.3
- base16-bytestring-0.1.1.6 - base16-bytestring-0.1.1.6
- base64-bytestring-1.0.0.1 - base64-bytestring-1.0.0.1
- basic-prelude-0.5.0 - basic-prelude-0.5.0
@ -40,6 +42,7 @@ extra-deps:
- byteable-0.1.1 - byteable-0.1.1
- byteorder-1.0.4 - byteorder-1.0.4
- bytestring-builder-0.10.6.0.0 - bytestring-builder-0.10.6.0.0
- carray-0.1.6.3
- case-insensitive-1.2.0.5 - case-insensitive-1.2.0.5
- cereal-0.5.1.0 - cereal-0.5.1.0
- chunked-data-0.2.0 - chunked-data-0.2.0
@ -53,7 +56,7 @@ extra-deps:
- comonad-4.2.7.2 - comonad-4.2.7.2
- conduit-1.2.6.1 - conduit-1.2.6.1
- conduit-combinators-1.0.3 - conduit-combinators-1.0.3
- conduit-extra-1.1.9.2 - conduit-extra-1.1.13.1
- connection-0.2.5 - connection-0.2.5
- contravariant-1.3.3 - contravariant-1.3.3
- convertible-1.1.1.0 - convertible-1.1.1.0
@ -85,6 +88,7 @@ extra-deps:
- exceptions-0.8.0.2 - exceptions-0.8.0.2
- extensible-exceptions-0.1.1.4 - extensible-exceptions-0.1.1.4
- fast-logger-2.4.1 - fast-logger-2.4.1
- fft-0.1.8.3
- file-embed-0.0.9 - file-embed-0.0.9
- filemanip-0.3.6.3 - filemanip-0.3.6.3
- free-4.12.1 - free-4.12.1
@ -95,9 +99,9 @@ extra-deps:
- hjsmin-0.1.5.1 - hjsmin-0.1.5.1
- hourglass-0.2.9 - hourglass-0.2.9
- hslua-0.4.1 - hslua-0.4.1
- hspec-2.2.2 - hspec-2.2.3
- hspec-core-2.2.2 - hspec-core-2.2.3
- hspec-discover-2.2.2 - hspec-discover-2.2.3
- hspec-expectations-0.7.2 - hspec-expectations-0.7.2
- html-conduit-1.2.1 - html-conduit-1.2.1
- http-api-data-0.2.2 - http-api-data-0.2.2
@ -110,6 +114,7 @@ extra-deps:
- image-type-0.1.0.0 - image-type-0.1.0.0
- imagemagick-0.0.4.1 - imagemagick-0.0.4.1
- iproute-1.7.0 - iproute-1.7.0
- ix-shapable-0.1.0
- kan-extensions-4.2.3 - kan-extensions-4.2.3
- keys-3.10.2 - keys-3.10.2
- language-javascript-0.5.14.2 - language-javascript-0.5.14.2
@ -122,7 +127,7 @@ extra-deps:
- monad-logger-0.3.16 - monad-logger-0.3.16
- monad-loops-0.4.3 - monad-loops-0.4.3
- monads-tf-0.1.0.2 - monads-tf-0.1.0.2
- mono-traversable-0.10.1 - mono-traversable-0.10.1.1
- mtl-2.2.1 - mtl-2.2.1
- mtl-compat-0.2.1.3 - mtl-compat-0.2.1.3
- mutable-containers-0.3.2 - mutable-containers-0.3.2
@ -138,10 +143,10 @@ extra-deps:
- parsec-3.1.9 - parsec-3.1.9
- path-pieces-0.2.1 - path-pieces-0.2.1
- pem-0.2.2 - pem-0.2.2
- persistent-2.2.4 - persistent-2.2.4.1
- persistent-postgresql-2.2.2 - persistent-postgresql-2.2.2
- persistent-sqlite-2.2 - persistent-sqlite-2.2.1
- persistent-template-2.1.5 - persistent-template-2.1.6
- pointed-4.2.0.2 - pointed-4.2.0.2
- postgresql-libpq-0.9.1.1 - postgresql-libpq-0.9.1.1
- postgresql-simple-0.5.1.2 - postgresql-simple-0.5.1.2
@ -169,6 +174,7 @@ extra-deps:
- split-0.2.2 - split-0.2.2
- stm-2.4.4.1 - stm-2.4.4.1
- stm-chans-3.0.0.4 - stm-chans-3.0.0.4
- storable-complex-0.2.2
- streaming-commons-0.1.15 - streaming-commons-0.1.15
- stringsearch-0.3.6.6 - stringsearch-0.3.6.6
- syb-0.6 - syb-0.6
@ -177,7 +183,7 @@ extra-deps:
- tagsoup-0.13.6 - tagsoup-0.13.6
- tagstream-conduit-0.5.5.3 - tagstream-conduit-0.5.5.3
- temporary-1.2.0.3 - temporary-1.2.0.3
- texmath-0.8.4.1 - texmath-0.8.6.1
- text-1.2.2.0 - text-1.2.2.0
- tf-random-0.5 - tf-random-0.5
- time-locale-compat-0.1.1.1 - time-locale-compat-0.1.1.1
@ -196,7 +202,7 @@ extra-deps:
- void-0.7.1 - void-0.7.1
- wai-3.0.5.0 - wai-3.0.5.0
- wai-app-static-3.1.4.1 - wai-app-static-3.1.4.1
- wai-extra-3.0.14 - wai-extra-3.0.15
- wai-logger-2.2.4.1 - wai-logger-2.2.4.1
- warp-3.1.12 - warp-3.1.12
- word8-0.1.2 - word8-0.1.2