aboutsummaryrefslogtreecommitdiff
path: root/compiler/src/Processors.hs
diff options
context:
space:
mode:
authorpacien2020-05-02 04:11:24 +0200
committerpacien2020-05-02 04:11:24 +0200
commit8e3ac8fe44bebb38e1882ca7f06b8100078ad88d (patch)
treea748fa1e639cb3b5e1f24a8150e89dbb28c980cb /compiler/src/Processors.hs
parent7042ffc06326fa8ffe70f5a59747709250166c16 (diff)
parent0e0b5b0ae44da7c1d67983dedd8f8d8d3516236f (diff)
downloadldgallery-8e3ac8fe44bebb38e1882ca7f06b8100078ad88d.tar.gz
Merge branch 'develop': release v1.0v1.0
Diffstat (limited to 'compiler/src/Processors.hs')
-rw-r--r--compiler/src/Processors.hs144
1 files changed, 73 insertions, 71 deletions
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs
index 159a425..02db325 100644
--- a/compiler/src/Processors.hs
+++ b/compiler/src/Processors.hs
@@ -25,20 +25,20 @@ module Processors
25 25
26 26
27import Control.Exception (Exception, throwIO) 27import Control.Exception (Exception, throwIO)
28import Control.Monad (when)
28import Data.Function ((&)) 29import Data.Function ((&))
29import Data.Ratio ((%))
30import Data.Char (toLower) 30import Data.Char (toLower)
31import Text.Read (readMaybe)
31 32
32import System.Directory hiding (copyFile) 33import System.Directory hiding (copyFile)
33import qualified System.Directory 34import qualified System.Directory
34import System.FilePath 35import System.FilePath
35 36
36import Codec.Picture 37import System.Process (callProcess, readProcess)
37import Codec.Picture.Extra -- TODO: compare DCT and bilinear (and Lanczos, but it's not implemented)
38 38
39import Resource 39import Resource
40 ( ItemProcessor, ThumbnailProcessor 40 ( ItemProcessor, ThumbnailProcessor
41 , GalleryItemProps(..), Resolution(..) ) 41 , GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..) )
42 42
43import Files 43import Files
44 44
@@ -47,10 +47,8 @@ data ProcessingException = ProcessingException FilePath String deriving Show
47instance Exception ProcessingException 47instance Exception ProcessingException
48 48
49 49
50data PictureFileFormat = Bmp | Jpg | Png | Tiff | Hdr | Gif
51
52-- TODO: handle video, music, text... 50-- TODO: handle video, music, text...
53data Format = PictureFormat PictureFileFormat | Unknown 51data Format = PictureFormat | Unknown
54 52
55formatFromPath :: Path -> Format 53formatFromPath :: Path -> Format
56formatFromPath = 54formatFromPath =
@@ -60,14 +58,15 @@ formatFromPath =
60 . fileName 58 . fileName
61 where 59 where
62 fromExt :: String -> Format 60 fromExt :: String -> Format
63 fromExt ".bmp" = PictureFormat Bmp 61 fromExt ext = case ext of
64 fromExt ".jpg" = PictureFormat Jpg 62 ".bmp" -> PictureFormat
65 fromExt ".jpeg" = PictureFormat Jpg 63 ".jpg" -> PictureFormat
66 fromExt ".png" = PictureFormat Png 64 ".jpeg" -> PictureFormat
67 fromExt ".tiff" = PictureFormat Tiff 65 ".png" -> PictureFormat
68 fromExt ".hdr" = PictureFormat Hdr 66 ".tiff" -> PictureFormat
69 fromExt ".gif" = PictureFormat Gif 67 ".hdr" -> PictureFormat
70 fromExt _ = Unknown 68 ".gif" -> PictureFormat
69 _ -> Unknown
71 70
72 71
73type FileProcessor = 72type FileProcessor =
@@ -80,43 +79,20 @@ copyFileProcessor inputPath outputPath =
80 (putStrLn $ "Copying:\t" ++ outputPath) 79 (putStrLn $ "Copying:\t" ++ outputPath)
81 >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath 80 >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath
82 81
83resizeStaticImageUpTo :: PictureFileFormat -> Resolution -> FileProcessor 82resizePictureUpTo :: Resolution -> FileProcessor
84resizeStaticImageUpTo Bmp = resizeStaticGeneric readBitmap saveBmpImage 83resizePictureUpTo maxResolution inputPath outputPath =
85-- TODO: parameterise export quality for jpg
86resizeStaticImageUpTo Jpg = resizeStaticGeneric readJpeg (saveJpgImage 80)
87resizeStaticImageUpTo Png = resizeStaticGeneric readPng savePngImage
88resizeStaticImageUpTo Tiff = resizeStaticGeneric readTiff saveTiffImage
89resizeStaticImageUpTo Hdr = resizeStaticGeneric readHDR saveRadianceImage
90resizeStaticImageUpTo Gif = resizeStaticGeneric readGif saveGifImage'
91 where
92 saveGifImage' :: StaticImageWriter
93 saveGifImage' outputPath image =
94 saveGifImage outputPath image
95 & either (throwIO . ProcessingException outputPath) id
96
97
98type StaticImageReader = FilePath -> IO (Either String DynamicImage)
99type StaticImageWriter = FilePath -> DynamicImage -> IO ()
100
101resizeStaticGeneric :: StaticImageReader -> StaticImageWriter -> Resolution -> FileProcessor
102resizeStaticGeneric reader writer maxRes inputPath outputPath =
103 (putStrLn $ "Generating:\t" ++ outputPath) 84 (putStrLn $ "Generating:\t" ++ outputPath)
104 >> reader inputPath 85 >> ensureParentDir (flip resize) outputPath inputPath
105 >>= either (throwIO . ProcessingException inputPath) return
106 >>= return . (fitDynamicImage maxRes)
107 >>= ensureParentDir writer outputPath
108
109fitDynamicImage :: Resolution -> DynamicImage -> DynamicImage
110fitDynamicImage (Resolution boxWidth boxHeight) image =
111 convertRGBA8 image
112 & scaleBilinear targetWidth targetHeight
113 & ImageRGBA8
114 where 86 where
115 picWidth = dynamicMap imageWidth image 87 maxSize :: Resolution -> String
116 picHeight = dynamicMap imageHeight image 88 maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">"
117 resizeRatio = min (boxWidth % picWidth) (boxHeight % picHeight) 89
118 targetWidth = floor $ resizeRatio * (picWidth % 1) 90 resize :: FileName -> FileName -> IO ()
119 targetHeight = floor $ resizeRatio * (picHeight % 1) 91 resize input output = callProcess "magick"
92 [ input
93 , "-auto-orient"
94 , "-resize", maxSize maxResolution
95 , output ]
120 96
121 97
122type Cache = FileProcessor -> FileProcessor 98type Cache = FileProcessor -> FileProcessor
@@ -130,7 +106,7 @@ withCached :: Cache
130withCached processor inputPath outputPath = 106withCached processor inputPath outputPath =
131 do 107 do
132 isDir <- doesDirectoryExist outputPath 108 isDir <- doesDirectoryExist outputPath
133 if isDir then removePathForcibly outputPath else noop 109 when isDir $ removePathForcibly outputPath
134 110
135 fileExists <- doesFileExist outputPath 111 fileExists <- doesFileExist outputPath
136 if fileExists then 112 if fileExists then
@@ -141,11 +117,39 @@ withCached processor inputPath outputPath =
141 update 117 update
142 118
143 where 119 where
144 noop = return ()
145 update = processor inputPath outputPath 120 update = processor inputPath outputPath
146 skip = putStrLn $ "Skipping:\t" ++ outputPath 121 skip = putStrLn $ "Skipping:\t" ++ outputPath
147 122
148 123
124resourceAt :: FilePath -> Path -> IO Resource
125resourceAt fsPath resPath = getModificationTime fsPath >>= return . Resource resPath
126
127getImageResolution :: FilePath -> IO Resolution
128getImageResolution fsPath =
129 readProcess "magick" ["identify", "-format", "%w %h", firstFrame] []
130 >>= parseResolution . break (== ' ')
131 where
132 firstFrame :: FilePath
133 firstFrame = fsPath ++ "[0]"
134
135 parseResolution :: (String, String) -> IO Resolution
136 parseResolution (widthString, heightString) =
137 case (readMaybe widthString, readMaybe heightString) of
138 (Just w, Just h) -> return $ Resolution w h
139 _ -> throwIO $ ProcessingException fsPath "Unable to read image resolution."
140
141getPictureProps :: ItemDescriber
142getPictureProps fsPath resource =
143 getImageResolution fsPath
144 >>= return . Picture resource
145
146
147type ItemDescriber =
148 FilePath
149 -> Resource
150 -> IO GalleryItemProps
151
152
149type ItemFileProcessor = 153type ItemFileProcessor =
150 FileName -- ^ Input base path 154 FileName -- ^ Input base path
151 -> FileName -- ^ Output base path 155 -> FileName -- ^ Output base path
@@ -154,23 +158,20 @@ type ItemFileProcessor =
154 158
155itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor 159itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor
156itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = 160itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes =
157 cached processor inPath outPath 161 cached processor inPath outPath
158 >> return (props relOutPath) 162 >> resourceAt outPath relOutPath
163 >>= descriptor outPath
159 where 164 where
160 relOutPath = resClass /> inputRes 165 relOutPath = resClass /> inputRes
161 inPath = localPath $ inputBase /> inputRes 166 inPath = localPath $ inputBase /> inputRes
162 outPath = localPath $ outputBase /> relOutPath 167 outPath = localPath $ outputBase /> relOutPath
163 (processor, props) = processorFor maxResolution $ formatFromPath inputRes 168 (processor, descriptor) = processorFor (formatFromPath inputRes) maxResolution
164 169
165 processorFor :: Maybe Resolution -> Format -> (FileProcessor, Path -> GalleryItemProps) 170 processorFor :: Format -> Maybe Resolution -> (FileProcessor, ItemDescriber)
166 processorFor Nothing _ = 171 processorFor PictureFormat (Just maxRes) = (resizePictureUpTo maxRes, getPictureProps)
167 (copyFileProcessor, Other) 172 processorFor PictureFormat Nothing = (copyFileProcessor, getPictureProps)
168 processorFor _ (PictureFormat Gif) = 173 -- TODO: handle video reencoding and others?
169 (copyFileProcessor, Picture) -- TODO: handle animated gif resizing 174 processorFor Unknown _ = (copyFileProcessor, const $ return . Other)
170 processorFor (Just maxRes) (PictureFormat picFormat) =
171 (resizeStaticImageUpTo picFormat maxRes, Picture)
172 processorFor _ Unknown =
173 (copyFileProcessor, Other) -- TODO: handle video reencoding and others?
174 175
175 176
176type ThumbnailFileProcessor = 177type ThumbnailFileProcessor =
@@ -188,14 +189,15 @@ thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes =
188 inPath = localPath $ inputBase /> inputRes 189 inPath = localPath $ inputBase /> inputRes
189 outPath = localPath $ outputBase /> relOutPath 190 outPath = localPath $ outputBase /> relOutPath
190 191
191 process :: Maybe FileProcessor -> IO (Maybe Path) 192 process :: Maybe FileProcessor -> IO (Maybe Thumbnail)
192 process Nothing = return Nothing 193 process Nothing = return Nothing
193 process (Just proc) = 194 process (Just proc) =
194 proc inPath outPath 195 do
195 >> return (Just relOutPath)