drops imagemagick

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
+      tdata <- generateThumb $ B.concat $ L.toChunks raw
-      runDB $ insert_ $ Avatar (avatarNewIdent na) thumb hash'
+      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
+    , AvatarData =. thumbContent tdata
-    , AvatarHash =. hash'
+    , 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
+  let eimg = decodeImageWithMetadata raw
-    (_, w) <- magickWand
+  case eimg of
-    readImageBlob w raw
+    Left e -> error e
-    w1 <- getImageWidth w
+    Right (img, meta) ->
-    h1 <- getImageHeight w
+      return $ ThumbData
-    let h2 = 140 :: Int
+        { thumbContent = ava
-    let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double) :: Int
+        , thumbHash    = h
-    resizeImage w w2 h2 lanczosFilter 1
+        }
-    setImageCompressionQuality w 95
+      where
-    setImageFormat w "png"
+        w1 = fromIntegral $ fromJust $ PM.lookup Width meta :: Int
-    getImageBlob w
+        h1 = fromIntegral $ fromJust $ PM.lookup Height meta :: Int
-  let h = encode (SHA3.hash 32 thumb)
+        h2 = 140 :: Int
-  return (thumb, h)
+        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

stack.yaml

@@ -1,18 +1,15 @@
-# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
+flags:
-
+  time-locale-compat:
-# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
+    old-locale: false
-resolver: ghc-7.10.3
+extra-package-dbs: []
-
-# Local packages, usually specified by relative directory name
 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
-
+resolver: ghc-7.10.3
-# 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]

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