dropping imegamagick for juicypixels

2016-05-07 21:23:03 +02:00 · 2016-05-07 21:23:03 +02:00 · dce81ef161
commit dce81ef161
parent eaa80952a6
3 changed files with 79 additions and 54 deletions
--- a/Handler/Upload.hs
+++ b/Handler/Upload.hs
@ -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
--- a/eidolon.cabal
+++ b/eidolon.cabal
@ -118,6 +118,8 @@ library
                 , bloodhound                    >= 0.8
                 , http-types
                 , image-type
+                 , JuicyPixels                   >= 3.2.7
+                 , JuicyPixels-scale-dct
                 -- for Migrations
                 , HDBC
                 , HDBC-postgresql
--- a/stack.yaml
+++ b/stack.yaml
@ -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