drops imagemagick

This commit is contained in:
nek0 2016-05-09 00:03:17 +02:00
parent cee0f17c77
commit 0f5e37c101
3 changed files with 49 additions and 57 deletions

View File

@ -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

View File

@ -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

View File

@ -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