dropping imegamagick for juicypixels

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

View file

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

View file

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

View file

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