thumbnail generation now working

This commit is contained in:
nek0 2014-12-02 08:02:40 +01:00
parent 0d32bdfff1
commit fdf7ab553d
6 changed files with 33 additions and 51 deletions

View file

@ -3,9 +3,11 @@ module Handler.Upload where
import Import as I import Import as I
import Data.Time import Data.Time
import qualified Data.Text as T import qualified Data.Text as T
import System.FilePath import qualified System.FilePath as FP
import Graphics.Transform.Magick.Images import qualified Filesystem.Path as FSP
import Graphics.Transform.Magick.Types import Filesystem.Path.CurrentOS
import Graphics.ImageMagick.MagickWand
import Control.Monad.Trans.Resource
import Foreign import Foreign
import Foreign.C.Types import Foreign.C.Types
import Foreign.C.String import Foreign.C.String
@ -145,42 +147,33 @@ postDirectUploadR albumId = do
setMessage "This Album does not exist" setMessage "This Album does not exist"
redirect $ AlbumR albumId redirect $ AlbumR albumId
generateThumb :: FilePath -> UserId -> AlbumId -> Handler FilePath generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler FP.FilePath
generateThumb path userId albumId = do generateThumb path userId albumId = do
liftIO $ initializeMagick newName <- return $ (FP.takeBaseName path) ++ "_thumb" ++ (FP.takeExtension path)
image <- liftIO $ readImage path newPath <- return $ "static" FP.</> "data"
case image of FP.</> (T.unpack $ extractKey userId)
HImage imag _ -> do FP.</> (T.unpack $ extractKey albumId)
h1 <- liftIO $ withForeignPtr imag (\a -> do FP.</> newName
himage <- peek a liftIO $ withMagickWandGenesis $ do
r <- return $ rows himage (_ , w) <- magickWand
case r of CULong ro -> return ro readImage w (decodeString path)
) w1 <- getImageWidth w
w1 <- liftIO $ withForeignPtr imag (\a -> do h1 <- getImageHeight w
himage <- peek a h2 <- return 220
c <- return $ columns himage w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2))
case c of CULong co -> return co resizeImage w w2 h2 lanczosFilter 1
) setImageCompressionQuality w 95
h2 <- return $ 220 writeImage w (Just (decodeString newPath))
w2 <- return $ (h1 `div` w1) * h2 return newPath
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
writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FilePath writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath
writeOnDrive file userId albumId = do writeOnDrive fil userId albumId = do
filen <- return $ fileName file filen <- return $ fileName fil
path <- return $ "static" </> "data" path <- return $ "static" FP.</> "data"
</> (T.unpack $ extractKey userId) FP.</> (T.unpack $ extractKey userId)
</> (T.unpack $ extractKey albumId) FP.</> (T.unpack $ extractKey albumId)
</> (T.unpack filen) FP.</> (T.unpack filen)
liftIO $ fileMove file path liftIO $ fileMove fil path
return path return path
uploadForm :: UserId -> Form TempMedium uploadForm :: UserId -> Form TempMedium

View file

@ -91,6 +91,7 @@ library
, mime-mail , mime-mail
, blaze-html , blaze-html
, filepath , filepath
, system-filepath
, time , time
, yesod-persistent , yesod-persistent
, transformers , transformers
@ -98,7 +99,8 @@ library
, cereal , cereal
, cryptohash-cryptoapi , cryptohash-cryptoapi
, crypto-api , crypto-api
, hsmagick , imagemagick
, resourcet
executable eidolon executable eidolon
if flag(library-only) if flag(library-only)

View file

@ -3,10 +3,6 @@
border-radius: 6px border-radius: 6px
box-shadow: 0 0 3px #c4c4c4 box-shadow: 0 0 3px #c4c4c4
.thumbnail img
width: 250px
margin: 0
ul ul
list-style-type: none list-style-type: none

View file

@ -3,9 +3,6 @@
border-radius: 6px border-radius: 6px
box-shadow: 0 0 3px #c4c4c4 box-shadow: 0 0 3px #c4c4c4
.thumbnail img
width: 250px
ul ul
list-style-type: none list-style-type: none

View file

@ -3,9 +3,6 @@
border-radius: 6px border-radius: 6px
box-shadow: 0 0 3px #c4c4c4 box-shadow: 0 0 3px #c4c4c4
.thumbnail img
width: 250px
ul ul
list-style-type: none list-style-type: none

View file

@ -3,9 +3,6 @@
border-radius: 6px border-radius: 6px
box-shadow: 0 0 3px #c4c4c4 box-shadow: 0 0 3px #c4c4c4
.thumbnail img
width: 250px
ul ul
list-style: none list-style: none