version bump: added preview images for large images

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

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

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

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

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

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: <http://www.yesodweb.com/>

config/models

@@ -53,6 +53,8 @@ Medium
     width Int
     thumbWidth Int
     album AlbumId
+    preview FP.FilePath
+    previewWidth Int
     deriving Eq Show
 Comment
     author UserId

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

templates/medium.hamlet

@@ -6,7 +6,8 @@
         by <a href=@{UserR ownerName}>#{ownerName}</a> from album <a href=@{AlbumR albumId}>#{albumTitle album}</a>
   <div id="header" class="item image" data-width=#{dataWidth}>
     <div class="inner">
-      <img sizes="(min-width: 40em) 80vw, 100vw" srcset="@{tr} 1x, @{pr} 2x" title=#{mediumTitle medium}>
+      <a href=@{ir}>
+        <img sizes="(min-width: 40em) 80vw, 100vw" srcset="@{tr} 1x, @{pr} 2x, @{ir} 3x" title=#{mediumTitle medium}>
 
   <div id="header" class="item" data-width="400">
     <div class="inner">