aboutsummaryrefslogtreecommitdiff
path: root/compiler/src/Processors.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src/Processors.hs')
-rw-r--r--compiler/src/Processors.hs221
1 files changed, 221 insertions, 0 deletions
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs
new file mode 100644
index 0000000..a296215
--- /dev/null
+++ b/compiler/src/Processors.hs
@@ -0,0 +1,221 @@
1-- ldgallery - A static generator which turns a collection of tagged
2-- pictures into a searchable web gallery.
3--
4-- Copyright (C) 2019 Pacien TRAN-GIRARD
5--
6-- This program is free software: you can redistribute it and/or modify
7-- it under the terms of the GNU Affero General Public License as
8-- published by the Free Software Foundation, either version 3 of the
9-- License, or (at your option) any later version.
10--
11-- This program is distributed in the hope that it will be useful,
12-- but WITHOUT ANY WARRANTY; without even the implied warranty of
13-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14-- GNU Affero General Public License for more details.
15--
16-- You should have received a copy of the GNU Affero General Public License
17-- along with this program. If not, see <https://www.gnu.org/licenses/>.
18
19{-# LANGUAGE
20 DuplicateRecordFields
21 , DeriveGeneric
22 , DeriveAnyClass
23 , FlexibleContexts
24#-}
25
26module Processors
27 ( Resolution(..)
28 , DirFileProcessor, dirFileProcessor
29 , ItemFileProcessor, itemFileProcessor
30 , ThumbnailFileProcessor, thumbnailFileProcessor
31 , skipCached, withCached
32 ) where
33
34
35import Control.Exception (throwIO)
36import Data.Function ((&))
37import Data.Ratio ((%))
38
39import System.Directory hiding (copyFile)
40import qualified System.Directory
41import System.FilePath
42
43import Codec.Picture
44import Codec.Picture.Extra -- TODO: compare DCT and bilinear (and Lanczos, but it's not implemented)
45
46import Resource
47import Files
48
49
50data Format =
51 Bmp | Jpg | Png | Tiff | Hdr -- static images
52 | Gif -- TODO: might be animated
53 | Other
54
55formatFromExt :: String -> Format
56formatFromExt ".bmp" = Bmp
57formatFromExt ".jpg" = Jpg
58formatFromExt ".jpeg" = Jpg
59formatFromExt ".png" = Png
60formatFromExt ".tiff" = Tiff
61formatFromExt ".hdr" = Hdr
62formatFromExt ".gif" = Gif
63formatFromExt _ = Other
64
65data Resolution = Resolution
66 { width :: Int
67 , height :: Int } deriving Show
68
69type FileProcessor =
70 FileName -- ^ Input path
71 -> FileName -- ^ Output path
72 -> IO ()
73
74copyFileProcessor :: FileProcessor
75copyFileProcessor inputPath outputPath =
76 (putStrLn $ "Copying: " ++ outputPath)
77 >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath
78
79eitherIOToIO :: Either String (IO a) -> IO a
80eitherIOToIO (Left err) = throwIO $ userError err
81eitherIOToIO (Right res) = res
82
83eitherResToIO :: Either String a -> IO a
84eitherResToIO (Left err) = throwIO $ userError err
85eitherResToIO (Right res) = return res
86
87resizeStaticImageUpTo :: Format -> Resolution -> FileProcessor
88resizeStaticImageUpTo Bmp = resizeStaticGeneric readBitmap saveBmpImage
89-- TODO: parameterise export quality for jpg
90resizeStaticImageUpTo Jpg = resizeStaticGeneric readJpeg (saveJpgImage 80)
91resizeStaticImageUpTo Png = resizeStaticGeneric readPng savePngImage
92resizeStaticImageUpTo Tiff = resizeStaticGeneric readTiff saveTiffImage
93resizeStaticImageUpTo Hdr = resizeStaticGeneric readHDR saveRadianceImage
94resizeStaticImageUpTo Gif = resizeStaticGeneric readGif ((.) eitherIOToIO . saveGifImage)
95
96
97type StaticImageReader = FilePath -> IO (Either String DynamicImage)
98type StaticImageWriter = FilePath -> DynamicImage -> IO ()
99
100resizeStaticGeneric :: StaticImageReader -> StaticImageWriter -> Resolution -> FileProcessor
101resizeStaticGeneric reader writer maxRes inputPath outputPath =
102 (putStrLn $ "Generating: " ++ outputPath)
103 >> reader inputPath
104 >>= eitherResToIO
105 >>= return . (fitDynamicImage maxRes)
106 >>= ensureParentDir writer outputPath
107
108fitDynamicImage :: Resolution -> DynamicImage -> DynamicImage
109fitDynamicImage (Resolution boxWidth boxHeight) image =
110 convertRGBA8 image
111 & scaleBilinear targetWidth targetHeight
112 & ImageRGBA8
113 where
114 picWidth = dynamicMap imageWidth image
115 picHeight = dynamicMap imageHeight image
116 resizeRatio = min (boxWidth % picWidth) (boxHeight % picHeight)
117 targetWidth = floor $ resizeRatio * (picWidth % 1)
118 targetHeight = floor $ resizeRatio * (picHeight % 1)
119
120
121type Cache = FileProcessor -> FileProcessor
122
123skipCached :: Cache
124skipCached processor inputPath outputPath =
125 removePathForcibly outputPath
126 >> processor inputPath outputPath
127
128withCached :: Cache
129withCached processor inputPath outputPath =
130 do
131 isDir <- doesDirectoryExist outputPath
132 if isDir then removePathForcibly outputPath else noop
133
134 fileExists <- doesFileExist outputPath
135 if fileExists then
136 do
137 needUpdate <- isOutdated inputPath outputPath
138 if needUpdate then update else skip
139 else
140 update
141
142 where
143 noop = return ()
144 update = processor inputPath outputPath
145 skip = putStrLn $ "Skipping: " ++ outputPath
146
147 isOutdated :: FilePath -> FilePath -> IO Bool
148 isOutdated ref target =
149 do
150 refTime <- getModificationTime ref
151 targetTime <- getModificationTime target
152 return (targetTime < refTime)
153
154
155type DirFileProcessor =
156 FileName -- ^ Input base path
157 -> FileName -- ^ Output base path
158 -> FileName -- ^ Output class (subdir)
159 -> DirProcessor
160
161dirFileProcessor :: DirFileProcessor
162dirFileProcessor _ _ = (.) return . (/>)
163
164
165type ItemFileProcessor =
166 FileName -- ^ Input base path
167 -> FileName -- ^ Output base path
168 -> FileName -- ^ Output class (subdir)
169 -> ItemProcessor
170
171itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor
172itemFileProcessor maxRes cached inputBase outputBase resClass inputRes =
173 cached (processor maxRes (extOf inputRes)) inPath outPath
174 >> return relOutPath
175 where
176 extOf = formatFromExt . takeExtension . head
177 relOutPath = resClass /> inputRes
178 inPath = localPath $ inputBase /> inputRes
179 outPath = localPath $ outputBase /> relOutPath
180
181 processor :: Maybe Resolution -> Format -> FileProcessor
182 processor Nothing _ = copyFileProcessor
183 processor (Just maxRes) Bmp = resizeStaticImageUpTo Bmp maxRes
184 processor (Just maxRes) Jpg = resizeStaticImageUpTo Jpg maxRes
185 processor (Just maxRes) Png = resizeStaticImageUpTo Png maxRes
186 processor (Just maxRes) Tiff = resizeStaticImageUpTo Tiff maxRes
187 processor (Just maxRes) Hdr = resizeStaticImageUpTo Hdr maxRes
188 processor _ Gif = copyFileProcessor -- TODO: handle animated gif resizing
189 processor _ Other = copyFileProcessor -- TODO: handle video reencoding and others?
190
191
192type ThumbnailFileProcessor =
193 FileName -- ^ Input base path
194 -> FileName -- ^ Output base path
195 -> FileName -- ^ Output class (subdir)
196 -> ThumbnailProcessor
197
198thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor
199thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes =
200 cached <$> processor (extOf inputRes)
201 & process
202 where
203 extOf = formatFromExt . takeExtension . head
204 relOutPath = resClass /> inputRes
205 inPath = localPath $ inputBase /> inputRes
206 outPath = localPath $ outputBase /> relOutPath
207
208 process :: Maybe FileProcessor -> IO (Maybe Path)
209 process Nothing = return Nothing
210 process (Just processor) =
211 processor inPath outPath
212 >> return (Just relOutPath)
213
214 processor :: Format -> Maybe FileProcessor
215 processor Bmp = Just $ resizeStaticImageUpTo Bmp maxRes
216 processor Jpg = Just $ resizeStaticImageUpTo Jpg maxRes
217 processor Png = Just $ resizeStaticImageUpTo Png maxRes
218 processor Tiff = Just $ resizeStaticImageUpTo Tiff maxRes
219 processor Hdr = Just $ resizeStaticImageUpTo Hdr maxRes
220 processor Gif = Just $ resizeStaticImageUpTo Gif maxRes -- static thumbnail from first frame
221 processor _ = Nothing