drops imagemagick
This commit is contained in:
nek0
parent
cee0f17c77
commit
0f5e37c101
3 changed files with 49 additions and 57 deletions
|
|
@ -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
|
||||
|
|
|
|||
47
stack.yaml
47
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue