From 4b511b7bbb5753ab8922f612a92f6f5b9f4d502e Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 20 Nov 2016 07:29:05 +0100 Subject: [PATCH] switching to png for thumbs and previews --- Handler/RootFeed.hs | 2 +- Handler/Upload.hs | 8 +- Migrations/0.1.3.3-0.1.4.0/Migration.hs | 102 ++++++++++++++++++++++++ eidolon.cabal | 3 +- 4 files changed, 109 insertions(+), 6 deletions(-) create mode 100755 Migrations/0.1.3.3-0.1.4.0/Migration.hs diff --git a/Handler/RootFeed.hs b/Handler/RootFeed.hs index 8b3e070..d67005e 100755 --- a/Handler/RootFeed.hs +++ b/Handler/RootFeed.hs @@ -195,7 +195,7 @@ mediumToEntry ent = do , feedEntryEnclosure = Just $ EntryEnclosure (StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPreview $ entityVal ent) []) size - "image/jpeg" + "image/png" } getSize :: FilePath -> IO Int diff --git a/Handler/Upload.hs b/Handler/Upload.hs index ad38cac..f953d16 100755 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -150,8 +150,8 @@ generateThumbs path uId aId mime = do _ -> error err Right img -> do -- This branch contains "classical" image formats like bmp or png return $ convertRGBA8 img - let thumbName = FP.takeBaseName path ++ "_thumb.jpg" - prevName = FP.takeBaseName path ++ "_preview.jpg" + let thumbName = FP.takeBaseName path ++ "_thumb.png" + prevName = FP.takeBaseName path ++ "_preview.png" pathPrefix = "static" FP. "data" FP. T.unpack (extractKey uId) FP. T.unpack (extractKey aId) tPath = pathPrefix FP. thumbName pPath = pathPrefix FP. prevName @@ -165,8 +165,8 @@ generateThumbs path uId aId mime = do pWidth = floor (fromIntegral oWidth * pScale) tPix = scale (tWidth, tHeight) orig pPix = scale (pWidth, pHeight) orig - liftIO $ saveJpgImage 95 tPath $ ImageRGBA8 tPix - liftIO $ saveJpgImage 95 pPath $ ImageRGBA8 pPix + liftIO $ savePngImage tPath $ ImageRGBA8 tPix + liftIO $ savePngImage pPath $ ImageRGBA8 pPix return $ ThumbsMeta { metaThumbPath = tPath , metaPreviewPath = pPath diff --git a/Migrations/0.1.3.3-0.1.4.0/Migration.hs b/Migrations/0.1.3.3-0.1.4.0/Migration.hs new file mode 100755 index 0000000..1c4d696 --- /dev/null +++ b/Migrations/0.1.3.3-0.1.4.0/Migration.hs @@ -0,0 +1,102 @@ +import Database.HDBC +import Database.HDBC.PostgreSQL +import System.IO +import System.Directory +import Control.Exception +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B +import Data.List.Split +import System.FilePath as FP +import Filesystem.Path.CurrentOS +import Codec.Picture as P +import Codec.Picture.ScaleDCT +import qualified Codec.Picture.Metadata as PM +import Graphics.Svg as SVG +import Graphics.Rasterific.Svg +import Graphics.Text.TrueType +import Magic + +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 + -- comment 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 <- mapM (\entry -> + case entry of + [("id", theId), _, ("path", SqlByteString bPath), _, _, _, ("owner", SqlInteger owner), _, _, ("album", SqlInteger album), _] -> do + let path = tail $ B.unpack bPath + eimg <- readImage path + orig <- case eimg of + Left err -> do -- This branch contains svg and other data formats. to be extended for pdf et al. + magic <- magicOpen [MagicMime] + magicLoadDefault magic + putStrLn path + mime <- head <$> splitOn ";" <$> magicFile magic path + putStrLn mime + case mime of + "image/svg+xml" -> do + svg <- loadSvgFile path + (img, _) <- renderSvgDocument emptyFontCache Nothing 100 $ fromJust svg + return img + _ -> error err + Right img -> do -- This branch contains "classical" image formats like bmp or png + return $ convertRGBA8 img + let thumbName = FP.takeBaseName path ++ "_thumb.png" + prevName = FP.takeBaseName path ++ "_preview.png" + oldThumbName = FP.takeBaseName path ++ "_thumb.jpg" + oldPrevName = FP.takeBaseName path ++ "_preview.jpg" + pathPrefix = "static" FP. "data" FP. show owner FP. show album + tPath = pathPrefix FP. thumbName + pPath = pathPrefix FP. prevName + -- origPix = convertRGBA8 orig + oWidth = P.imageWidth orig :: Int + oHeight = P.imageHeight orig :: Int + tWidth = floor (fromIntegral oWidth / fromIntegral oHeight * fromIntegral tHeight :: Double) + tHeight = 230 :: Int + pHeight = 600 :: Int + pScale = (fromIntegral pHeight :: Double) / (fromIntegral oHeight :: Double) + pWidth = floor (fromIntegral oWidth * pScale) + tPix = scale (tWidth, tHeight) orig + pPix = scale (pWidth, pHeight) orig + savePngImage tPath $ ImageRGBA8 tPix + savePngImage pPath $ ImageRGBA8 pPix + mapM (removeFile . (FP.) pathPrefix) [oldThumbName, oldPrevName] + return [SqlByteString (B.pack $ '/':tPath), SqlByteString (B.pack $ '/':pPath), theId] + _ -> + error "malformed entry" + ) rows + stmt2 <- prepare conn "update medium set thumb = ?, preview = ? 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/eidolon.cabal b/eidolon.cabal index 28ad224..380cc4e 100755 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -1,5 +1,5 @@ name: eidolon -version: 0.1.3.3 +version: 0.1.4.0 synopsis: Image gallery in Yesod homepage: https://eidolon.nek0.eu license: AGPL-3 @@ -136,6 +136,7 @@ library , bytestring , http-client , yesod-form >= 1.4.7 + , magic executable eidolon if flag(library-only)