From fdf7ab553d9bb9ffbf5e36266540a6f406d02e24 Mon Sep 17 00:00:00 2001
From: nek0 <nek0@chelnok.de>
Date: Tue, 2 Dec 2014 08:02:40 +0100
Subject: [PATCH] thumbnail generation now working

---
 Handler/Upload.hs          | 67 +++++++++++++++++---------------------
 eidolon.cabal              |  4 ++-
 templates/album.cassius    |  4 ---
 templates/home.cassius     |  3 --
 templates/profile.cassius  |  3 --
 templates/tagMedia.cassius |  3 --
 6 files changed, 33 insertions(+), 51 deletions(-)

diff --git a/Handler/Upload.hs b/Handler/Upload.hs
index 09fde1d..8d8ff40 100644
--- a/Handler/Upload.hs
+++ b/Handler/Upload.hs
@@ -3,9 +3,11 @@ module Handler.Upload where
 import Import as I
 import Data.Time
 import qualified Data.Text as T
-import System.FilePath
-import Graphics.Transform.Magick.Images
-import Graphics.Transform.Magick.Types
+import qualified System.FilePath as FP
+import qualified Filesystem.Path as FSP
+import Filesystem.Path.CurrentOS
+import Graphics.ImageMagick.MagickWand
+import Control.Monad.Trans.Resource
 import Foreign
 import Foreign.C.Types
 import Foreign.C.String
@@ -145,42 +147,33 @@ postDirectUploadR albumId = do
       setMessage "This Album does not exist"
       redirect $ AlbumR albumId
 
-generateThumb :: FilePath -> UserId -> AlbumId -> Handler FilePath
+generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler FP.FilePath
 generateThumb path userId albumId = do
-  liftIO $ initializeMagick
-  image <- liftIO $ readImage path
-  case image of
-    HImage imag _ -> do
-      h1 <- liftIO $ withForeignPtr imag (\a -> do
-        himage <- peek a
-        r <- return $ rows himage
-        case r of CULong ro -> return ro
-        )
-      w1 <- liftIO $ withForeignPtr imag (\a -> do
-        himage <- peek a
-        c <- return $ columns himage
-        case c of CULong co -> return co
-        )
-      h2 <- return $ 220
-      w2 <- return $ (h1 `div` w1) * h2
-      error $ show w2
-      thumb <- return $ thumbnailImage (fromIntegral w2) (fromIntegral h2) image
-      newName <- return $ (takeBaseName path) ++ "_thumb" ++ (takeExtension path)
-      newPath <- return $ "static" </> "data" 
-        </> (T.unpack $ extractKey userId)
-        </> (T.unpack $ extractKey albumId)
-        </> newName
-      _ <- liftIO $ writeImage newPath thumb
-      return newPath
+  newName <- return $ (FP.takeBaseName path) ++ "_thumb" ++ (FP.takeExtension path)
+  newPath <- return $ "static" FP.</> "data"
+    FP.</> (T.unpack $ extractKey userId)
+    FP.</> (T.unpack $ extractKey albumId)
+    FP.</> newName
+  liftIO $ withMagickWandGenesis $ do
+    (_ , w) <- magickWand
+    readImage w (decodeString path)
+    w1 <- getImageWidth w
+    h1 <- getImageHeight w
+    h2 <- return 220
+    w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2))
+    resizeImage w w2 h2 lanczosFilter 1
+    setImageCompressionQuality w 95
+    writeImage w (Just (decodeString newPath))
+  return newPath
 
-writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FilePath
-writeOnDrive file userId albumId = do
-  filen <- return $ fileName file
-  path <- return $ "static" </> "data"
-    </> (T.unpack $ extractKey userId)
-    </> (T.unpack $ extractKey albumId)
-    </> (T.unpack filen)
-  liftIO $ fileMove file path
+writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
+writeOnDrive fil userId albumId = do
+  filen <- return $ fileName fil
+  path <- return $ "static" FP.</> "data"
+    FP.</> (T.unpack $ extractKey userId)
+    FP.</> (T.unpack $ extractKey albumId)
+    FP.</> (T.unpack filen)
+  liftIO $ fileMove fil path
   return path
 
 uploadForm :: UserId -> Form TempMedium
diff --git a/eidolon.cabal b/eidolon.cabal
index 894e571..8c34cf4 100644
--- a/eidolon.cabal
+++ b/eidolon.cabal
@@ -91,6 +91,7 @@ library
                  , mime-mail
                  , blaze-html
                  , filepath
+                 , system-filepath
                  , time
                  , yesod-persistent
                  , transformers
@@ -98,7 +99,8 @@ library
                  , cereal
                  , cryptohash-cryptoapi
                  , crypto-api
-                 , hsmagick
+                 , imagemagick
+                 , resourcet
 
 executable         eidolon
     if flag(library-only)
diff --git a/templates/album.cassius b/templates/album.cassius
index 9e6d67f..125379d 100644
--- a/templates/album.cassius
+++ b/templates/album.cassius
@@ -3,10 +3,6 @@
   border-radius: 6px
   box-shadow: 0 0 3px #c4c4c4
 
-.thumbnail img
-  width: 250px
-  margin: 0
-
 ul
   list-style-type: none
 
diff --git a/templates/home.cassius b/templates/home.cassius
index ff8de9a..125379d 100644
--- a/templates/home.cassius
+++ b/templates/home.cassius
@@ -3,9 +3,6 @@
   border-radius: 6px
   box-shadow: 0 0 3px #c4c4c4
 
-.thumbnail img
-  width: 250px
-
 ul
   list-style-type: none
 
diff --git a/templates/profile.cassius b/templates/profile.cassius
index ff8de9a..125379d 100644
--- a/templates/profile.cassius
+++ b/templates/profile.cassius
@@ -3,9 +3,6 @@
   border-radius: 6px
   box-shadow: 0 0 3px #c4c4c4
 
-.thumbnail img
-  width: 250px
-
 ul
   list-style-type: none
 
diff --git a/templates/tagMedia.cassius b/templates/tagMedia.cassius
index 695c565..c0ac854 100644
--- a/templates/tagMedia.cassius
+++ b/templates/tagMedia.cassius
@@ -3,9 +3,6 @@
   border-radius: 6px
   box-shadow: 0 0 3px #c4c4c4
 
-.thumbnail img
-  width: 250px
-
 ul
   list-style: none