switching to png for thumbs and previews

This commit is contained in:
nek0 2016-11-20 07:29:05 +01:00
parent daef00e946
commit 4b511b7bbb
4 changed files with 109 additions and 6 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)