From 0f5e37c1012303c1e08c4cf3a90c14471bfa6db6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 9 May 2016 00:03:17 +0200 Subject: [PATCH] drops imagemagick --- Handler/Avatar.hs | 54 +++++++++++++++++++++++++++++------------------ stack.yaml | 47 +++++++++++------------------------------ yammat.cabal | 5 +++-- 3 files changed, 49 insertions(+), 57 deletions(-) diff --git a/Handler/Avatar.hs b/Handler/Avatar.hs index 3a3e87f..3bb82e8 100644 --- a/Handler/Avatar.hs +++ b/Handler/Avatar.hs @@ -21,8 +21,11 @@ import Data.Conduit.Binary import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Base64 -import Graphics.ImageMagick.MagickWand +import Data.Maybe (fromJust) import qualified Crypto.Hash.SHA3 as SHA3 +import Codec.Picture +import Codec.Picture.Metadata as PM hiding (delete) +import Codec.Picture.ScaleDCT getAvatarR :: Handler Html getAvatarR = do @@ -44,8 +47,11 @@ postNewAvatarR = do case res of FormSuccess na -> do raw <- runResourceT $ fileSource (avatarNewFile na) $$ sinkLbs - (thumb, hash') <- generateThumb $ B.concat $ L.toChunks raw - runDB $ insert_ $ Avatar (avatarNewIdent na) thumb hash' + tdata <- generateThumb $ B.concat $ L.toChunks raw + runDB $ insert_ $ Avatar + (avatarNewIdent na) + (thumbContent tdata) + (thumbHash tdata) setMessageI MsgAvatarUploadSuccessfull redirect HomeR _ -> do @@ -113,28 +119,36 @@ updateAvatar aId (AvatarMod ident Nothing) = runDB $ update aId [AvatarIdent =. ident] updateAvatar aId (AvatarMod ident (Just fi)) = do raw <- runResourceT $ fileSource fi $$ sinkLbs - (thumb, hash') <- generateThumb $ B.concat $ L.toChunks raw + tdata <- generateThumb $ B.concat $ L.toChunks raw runDB $ update aId [ AvatarIdent =. ident - , AvatarData =. thumb - , AvatarHash =. hash' + , AvatarData =. thumbContent tdata + , AvatarHash =. thumbHash tdata ] -generateThumb :: ByteString -> Handler (ByteString, ByteString) +data ThumbData = ThumbData + { thumbContent :: ByteString + , thumbHash :: ByteString + } + +generateThumb :: ByteString -> Handler ThumbData generateThumb raw = do - thumb <- liftIO $ withMagickWandGenesis $ do - (_, w) <- magickWand - readImageBlob w raw - w1 <- getImageWidth w - h1 <- getImageHeight w - let h2 = 140 :: Int - let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double) :: Int - resizeImage w w2 h2 lanczosFilter 1 - setImageCompressionQuality w 95 - setImageFormat w "png" - getImageBlob w - let h = encode (SHA3.hash 32 thumb) - return (thumb, h) + let eimg = decodeImageWithMetadata raw + case eimg of + Left e -> error e + Right (img, meta) -> + return $ ThumbData + { thumbContent = ava + , thumbHash = h + } + where + w1 = fromIntegral $ fromJust $ PM.lookup Width meta :: Int + h1 = fromIntegral $ fromJust $ PM.lookup Height meta :: Int + h2 = 140 :: Int + w2 = floor ((fromIntegral w1 :: Double) / (fromIntegral h1 :: Double) * (fromIntegral h2 :: Double)) :: Int + scimg = scale (w2, h2) $ convertRGBA8 img + ava = (B.concat . L.toChunks) $ encodePng scimg + h = encode (SHA3.hash 32 ava) getGetAvatarR :: AvatarId -> Handler TypedContent getGetAvatarR aId = do diff --git a/stack.yaml b/stack.yaml index d701206..679bf97 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,18 +1,15 @@ -# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md - -# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: ghc-7.10.3 - -# Local packages, usually specified by relative directory name +flags: + time-locale-compat: + old-locale: false +extra-package-dbs: [] packages: - '.' - -# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: - HDBC-2.4.0.1 - HDBC-postgresql-2.3.2.3 - HUnit-1.3.1.1 -- MonadCatchIO-transformers-0.3.1.3 +- JuicyPixels-3.2.7 +- JuicyPixels-scale-dct-0.1.1.0 - QuickCheck-2.8.2 - ReadArgs-1.2.2 - StateVar-1.1.0.3 @@ -29,6 +26,7 @@ extra-deps: - attoparsec-0.13.0.1 - authenticate-1.3.3 - auto-update-0.1.3 +- base-compat-0.9.0 - base-orphans-0.5.0 - base16-bytestring-0.1.1.6 - base64-bytestring-1.0.0.1 @@ -41,6 +39,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 @@ -79,8 +78,8 @@ extra-deps: - enclosed-exceptions-1.0.1.1 - entropy-0.3.7 - exceptions-0.8.2.1 -- extensible-exceptions-0.1.1.4 - fast-logger-2.4.1 +- fft-0.1.8.3 - file-embed-0.0.9.1 - free-4.12.4 - hashable-1.2.4.0 @@ -96,8 +95,8 @@ extra-deps: - http-conduit-2.1.8 - http-date-0.0.6.1 - http-types-0.9 -- imagemagick-0.0.4.1 - iproute-1.7.0 +- ix-shapable-0.1.0 - kan-extensions-5.0.1 - keys-3.11 - language-javascript-0.5.14.2 @@ -109,7 +108,6 @@ extra-deps: - monad-control-1.0.0.5 - monad-logger-0.3.17 - monad-loops-0.4.3 -- monads-tf-0.1.0.2 - mono-traversable-0.10.1 - mtl-2.2.1 - mutable-containers-0.3.2 @@ -155,6 +153,7 @@ extra-deps: - split-0.2.3 - 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 @@ -203,26 +202,4 @@ extra-deps: - yesod-static-1.4.0.4 - yesod-test-1.4.4 - zlib-0.6.1.1 - -# Override default flag values for local packages and extra-deps -flags: - time-locale-compat: - old-locale: false - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true - -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: >= 0.1.10.0 - -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 - -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] +resolver: ghc-7.10.3 diff --git a/yammat.cabal b/yammat.cabal index c03ea29..376408c 100644 --- a/yammat.cabal +++ b/yammat.cabal @@ -1,5 +1,5 @@ name: yammat -version: 0.0.3 +version: 0.0.4 cabal-version: >= 1.8 build-type: Simple license: AGPL-3 @@ -107,7 +107,8 @@ library , blaze-builder , split , conduit-extra - , imagemagick + , JuicyPixels >= 3.2.7 + , JuicyPixels-scale-dct , cryptohash , base64-bytestring -- for Migrations