diff --git a/Handler/AdminMediumSettings.hs b/Handler/AdminMediumSettings.hs index 93c0529..3b44a81 100644 --- a/Handler/AdminMediumSettings.hs +++ b/Handler/AdminMediumSettings.hs @@ -90,6 +90,7 @@ adminMediumSetForm :: Medium -> Form Medium adminMediumSetForm medium = renderDivs $ Medium <$> areq textField "Title" (Just $ mediumTitle medium) <*> pure (mediumPath medium) + <*> pure (mediumThumb medium) <*> pure (mediumTime medium) <*> pure (mediumOwner medium) <*> areq textareaField "Description" (Just $ mediumDescription medium) diff --git a/Handler/MediumSettings.hs b/Handler/MediumSettings.hs index b3f98dd..3756813 100644 --- a/Handler/MediumSettings.hs +++ b/Handler/MediumSettings.hs @@ -74,6 +74,7 @@ mediumSettingsForm :: Medium -> Form Medium mediumSettingsForm medium = renderDivs $ Medium <$> areq textField "Title" (Just $ mediumTitle medium) <*> pure (mediumPath medium) + <*> pure (mediumThumb medium) <*> pure (mediumTime medium) <*> pure (mediumOwner medium) <*> areq textareaField "Description" (Just $ mediumDescription medium) @@ -132,6 +133,7 @@ postMediumDeleteR mediumId = do -- update reference List runDB $ update albumId [AlbumContent =. newMediaList] liftIO $ removeFile (normalise $ tail $ mediumPath medium) + liftIO $ removeFile (normalise $ tail $ mediumThumb medium) runDB $ delete mediumId setMessage "Medium succesfully deleted" redirect $ HomeR diff --git a/Handler/Upload.hs b/Handler/Upload.hs index dc4214c..09fde1d 100644 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -4,6 +4,11 @@ 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 Foreign +import Foreign.C.Types +import Foreign.C.String data TempMedium = TempMedium { tempMediumTitle :: Text @@ -39,10 +44,12 @@ postUploadR = do case result of FormSuccess temp -> do path <- writeOnDrive (tempMediumFile temp) userId (tempMediumAlbum temp) + thumbPath <- generateThumb path userId (tempMediumAlbum temp) inAlbumId <- return $ tempMediumAlbum temp medium <- return $ Medium (tempMediumTitle temp) ('/' : path) + ('/' : thumbPath) (tempMediumTime temp) (tempMediumOwner temp) (tempMediumDesc temp) @@ -109,9 +116,11 @@ postDirectUploadR albumId = do case result of FormSuccess temp -> do path <- writeOnDrive (tempMediumFile temp) userId albumId + thumbPath <- generateThumb path ownerId albumId medium <- return $ Medium (tempMediumTitle temp) ('/' : path) + ('/' : thumbPath) (tempMediumTime temp) (tempMediumOwner temp) (tempMediumDesc temp) @@ -136,13 +145,41 @@ postDirectUploadR albumId = do setMessage "This Album does not exist" redirect $ AlbumR albumId +generateThumb :: FilePath -> UserId -> AlbumId -> Handler 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 + writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FilePath writeOnDrive file userId albumId = do - filename <- return $ fileName file + filen <- return $ fileName file path <- return $ "static" > "data" > (T.unpack $ extractKey userId) > (T.unpack $ extractKey albumId) - > (T.unpack filename) + > (T.unpack filen) liftIO $ fileMove file path return path diff --git a/config/models b/config/models index 8eead79..15dcfe4 100644 --- a/config/models +++ b/config/models @@ -25,6 +25,7 @@ Album Medium title Text path FilePath + thumb FilePath time UTCTime owner UserId description Textarea diff --git a/eidolon.cabal b/eidolon.cabal index 489cfe7..894e571 100644 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -98,6 +98,7 @@ library , cereal , cryptohash-cryptoapi , crypto-api + , hsmagick executable eidolon if flag(library-only) diff --git a/templates/album.hamlet b/templates/album.hamlet index 05d7d05..dba8634 100644 --- a/templates/album.hamlet +++ b/templates/album.hamlet @@ -16,5 +16,5 @@ by #{ownerName}