thumbnail generation now working
This commit is contained in:
parent
0d32bdfff1
commit
fdf7ab553d
6 changed files with 33 additions and 51 deletions
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue