diff --git a/Handler/AdminMediumSettings.hs b/Handler/AdminMediumSettings.hs index 5d6a5ee..42ce781 100644 --- a/Handler/AdminMediumSettings.hs +++ b/Handler/AdminMediumSettings.hs @@ -96,6 +96,8 @@ adminMediumSetForm medium = renderDivs $ Medium <*> pure (mediumWidth medium) <*> pure (mediumThumbWidth medium) <*> pure (mediumAlbum medium) + <*> pure (mediumPreview medium) + <*> pure (mediumPreviewWidth medium) getAdminMediumDeleteR :: MediumId -> Handler Html getAdminMediumDeleteR mediumId = do diff --git a/Handler/Medium.hs b/Handler/Medium.hs index 6f90711..65deee1 100644 --- a/Handler/Medium.hs +++ b/Handler/Medium.hs @@ -60,7 +60,8 @@ getMediumR mediumId = do [ Desc CommentTime ] let dataWidth = if mediumWidth medium >= 850 then 850 else mediumWidth medium let tr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumThumb medium) [] - let pr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) [] + let pr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) [] + let ir = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) [] formLayout $ do setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium)) rssLink (CommentFeedRssR mediumId) $ "Comment feed of medium " `T.append` mediumTitle medium diff --git a/Handler/MediumSettings.hs b/Handler/MediumSettings.hs index 34af5af..f5991ff 100644 --- a/Handler/MediumSettings.hs +++ b/Handler/MediumSettings.hs @@ -71,6 +71,8 @@ mediumSettingsForm medium = renderDivs $ Medium <*> pure (mediumWidth medium) <*> pure (mediumThumbWidth medium) <*> pure (mediumAlbum medium) + <*> pure (mediumPreview medium) + <*> pure (mediumPreviewWidth medium) getMediumDeleteR :: MediumId -> Handler Html getMediumDeleteR mediumId = do diff --git a/Handler/Upload.hs b/Handler/Upload.hs index 9aa172c..0f3d6d2 100644 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -80,12 +80,12 @@ postDirectUploadR albumId = do mime `elem` acceptedTypes then do path <- writeOnDrive file ownerId albumId - (thumbPath, iWidth, tWidth) <- generateThumb path ownerId albumId + (thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb 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 + let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth albumId ('/' : prevPath) pWidth mId <- runDB $ I.insert medium inALbum <- runDB $ getJust albumId let newMediaList = mId : albumContent inALbum @@ -118,24 +118,35 @@ postDirectUploadR albumId = do setMessage "This Album does not exist" redirect $ AlbumR albumId -generateThumb :: FP.FilePath -> UserId -> AlbumId -> Handler (FP.FilePath, Int, Int) +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 - (iWidth, tWidth) <- liftIO $ withMagickWandGenesis $ do - (_ , w) <- magickWand + 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 (decodeString path) + readImage p (decodeString path) w1 <- getImageWidth w h1 <- getImageHeight w let h2 = 230 let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double) + let h3 = h1 `div` 2 + let w3 = w1 `div` 2 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 (decodeString newPath)) - return (w1, w2) - return (newPath, iWidth, tWidth) + writeImage p (Just (decodeString prevPath)) + return (w1, w2, w3) + return (newPath, prevPath, iWidth, tWidth, pWidth) writeOnDrive :: FileInfo -> UserId -> AlbumId -> Handler FP.FilePath writeOnDrive fil userId albumId = do @@ -230,12 +241,12 @@ postUploadR = do albRef <- runDB $ getJust inAlbumId let ownerId = albumOwner albRef path <- writeOnDrive file ownerId inAlbumId - (thumbPath, iWidth, tWidth) <- generateThumb path ownerId inAlbumId + (thumbPath, prevPath, iWidth, tWidth, pWidth) <- generateThumb 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 + let medium = Medium tempName ('/' : path) ('/' : thumbPath) mime (fileBulkTime temp) (fileBulkOwner temp) (fileBulkDesc temp) (fileBulkTags temp) iWidth tWidth inAlbumId ('/' : prevPath) pWidth mId <- runDB $ I.insert medium inALbum <- runDB $ getJust inAlbumId let newMediaList = mId : albumContent inALbum diff --git a/Migrations/0.0.3-0.0.4/Migration.hs b/Migrations/0.0.3-0.0.4/Migration.hs new file mode 100644 index 0000000..e7aad6a --- /dev/null +++ b/Migrations/0.0.3-0.0.4/Migration.hs @@ -0,0 +1,71 @@ +import Database.HDBC +import Database.HDBC.PostgreSQL +import System.IO +import Control.Exception +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B +import System.FilePath as FP +import Filesystem.Path.CurrentOS +import Graphics.ImageMagick.MagickWand + +main :: IO () +main = do + putStrLn "Enter database host" + dbHost <- getLine + putStrLn "Enter database port" + dbPort <- getLine + putStrLn "Enter database user" + dbUser <- getLine + putStrLn "Enter database name" + dbName <- getLine + putStrLn "Enter database password" + dbPasswd <- getPasswd + let dbString = "host=" ++ dbHost ++ " port=" ++ dbPort ++ " user=" ++ dbUser ++ " dbname=" ++ dbName ++ " password=" ++ dbPasswd + conn <- connectPostgreSQL dbString + -- Uncomment next two lines, if eidolon has been run after the update + _ <- run conn "alter table medium add column preview varchar not null default 'fill_me!'" [] + _ <- run conn "alter table medium add column preview_width int8 not null default 0" [] + stmt1 <- prepare conn "select * from medium" + _ <- execute stmt1 [] + rows <- fetchAllRowsAL stmt1 + -- mapM_ (putStrLn . show) rows + tups <- sequence $ map (\entry -> + case entry of + [("id", theId), _, ("path", SqlByteString path), _, _, _, ("owner", SqlInteger owner), _, _, _, _, ("album", SqlInteger album), _, _] -> do + let newName = takeBaseName (B.unpack path) ++ "_thumb.jpg" + let newPath = "static" FP. "data" FP. show owner FP. show album FP. newName + pWidth <- withMagickWandGenesis $ do + (_, w) <- magickWand + readImage w (decodeString $ tail $ B.unpack path) + w1 <- getImageWidth w + h1 <- getImageHeight w + let w2 = w1 `div` 2 + let h2 = h1 `div` 2 + setImageAlphaChannel w deactivateAlphaChannel + setImageFormat w (T.pack "jpeg") + resizeImage w w2 h2 lanczosFilter 1 + setImageCompressionQuality w 95 + writeImage w (Just (decodeString newPath)) + return w2 + return [SqlByteString (B.pack newPath), SqlInteger (fromIntegral pWidth), theId] + _ -> + error "malformed entry" + ) rows + stmt2 <- prepare conn "update medium set preview = ?, preview_width = ? where id = ?" + executeMany stmt2 tups + commit conn + disconnect conn + putStrLn "Migration successfull!!" + +getPasswd :: IO String +getPasswd = do + putStr "Password: " + hFlush stdout + pass <- withEcho False getLine + putChar '\n' + return pass + +withEcho :: Bool -> IO a -> IO a +withEcho echo action = do + old <- hGetEcho stdin + bracket_ (hSetEcho stdin echo) (hSetEcho stdin old) action diff --git a/README.md b/README.md index a7b0d3d..4d23b02 100644 --- a/README.md +++ b/README.md @@ -44,7 +44,7 @@ After installing all dependencies you can configure and build the software with ```bash cabal configure -cabal build +cabal build exe:eidolon ``` ##Deploying @@ -65,6 +65,16 @@ You can start the gallery now by running the executable. You need to provide a s Since eidolon will block your console, I recommend wrapping a init-script around it. how you can do that is written in my [blog](http://nek0.eu/posts/2014-10-23-Daemonize-a-yesod-app.html). +##Migrations + +###0.0.3-0.0.4 + +* do not start or restart your eidolon service before migration +* build the Migration script with `cabal build Migration1` +* Migration script is located in `dist/build/Migration1/` in your build directory +* run Migration script from your run location (where your `static` folder with all the images are located) +* start or restart your eidolon service + ##Acknowledgements: * This software uses the web Framework "Yesod" by Michael Snoyman. See more at: diff --git a/config/models b/config/models index fb17f80..f1bd4b9 100644 --- a/config/models +++ b/config/models @@ -53,6 +53,8 @@ Medium width Int thumbWidth Int album AlbumId + preview FP.FilePath + previewWidth Int deriving Eq Show Comment author UserId diff --git a/eidolon.cabal b/eidolon.cabal index 6c1d352..68a11f2 100644 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -1,5 +1,5 @@ name: eidolon -version: 0.0.3 +version: 0.0.4 synopsis: Image gallery in Yesod homepage: https://eidolon.nek0.eu license: AGPL-3 @@ -116,7 +116,7 @@ library executable eidolon if flag(library-only) - Buildable: False + Buildable: True main-is: main.hs hs-source-dirs: app @@ -126,6 +126,20 @@ executable eidolon ghc-options: -threaded -O2 +executable Migrate1 + + main-is: Migration.hs + hs-source-dirs: Migrations/0.0.3-0.0.4 + ghc-options: -Wall + build-depends: base + , HDBC + , HDBC-postgresql + , imagemagick + , text + , filepath + , system-filepath + , bytestring + test-suite test type: exitcode-stdio-1.0 main-is: main.hs diff --git a/templates/medium.hamlet b/templates/medium.hamlet index efdbffd..af57094 100644 --- a/templates/medium.hamlet +++ b/templates/medium.hamlet @@ -6,7 +6,8 @@ by #{ownerName} from album #{albumTitle album}