diff options
author | pacien | 2020-06-13 10:58:00 +0200 |
---|---|---|
committer | pacien | 2020-06-16 18:23:25 +0200 |
commit | 8905383e2d17e2adb4097e1ce2e7f90ab9ceb5f5 (patch) | |
tree | 70be5303eb820e5a010be5b9e9a0e69e7313636f /compiler/src/Processors.hs | |
parent | ce2210e6deff1d981186b6d7ddb1176f27e41f49 (diff) | |
download | ldgallery-8905383e2d17e2adb4097e1ce2e7f90ab9ceb5f5.tar.gz |
compiler: split ItemProcessors, FileProcessors and Caching
Diffstat (limited to 'compiler/src/Processors.hs')
-rw-r--r-- | compiler/src/Processors.hs | 223 |
1 files changed, 0 insertions, 223 deletions
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs deleted file mode 100644 index 73529ee..0000000 --- a/compiler/src/Processors.hs +++ /dev/null | |||
@@ -1,223 +0,0 @@ | |||
1 | -- ldgallery - A static generator which turns a collection of tagged | ||
2 | -- pictures into a searchable web gallery. | ||
3 | -- | ||
4 | -- Copyright (C) 2019-2020 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 | module Processors | ||
20 | ( Resolution(..) | ||
21 | , ItemFileProcessor, itemFileProcessor | ||
22 | , ThumbnailFileProcessor, thumbnailFileProcessor | ||
23 | , skipCached, withCached | ||
24 | ) where | ||
25 | |||
26 | |||
27 | import Control.Exception (Exception, throwIO) | ||
28 | import Control.Monad (when) | ||
29 | import Data.Function ((&)) | ||
30 | import Data.Char (toLower) | ||
31 | import Text.Read (readMaybe) | ||
32 | |||
33 | import System.Directory hiding (copyFile) | ||
34 | import qualified System.Directory | ||
35 | import System.FilePath | ||
36 | |||
37 | import System.Process (callProcess, readProcess) | ||
38 | |||
39 | import Resource | ||
40 | ( ItemProcessor, ThumbnailProcessor | ||
41 | , GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..) ) | ||
42 | |||
43 | import Files | ||
44 | |||
45 | |||
46 | data ProcessingException = ProcessingException FilePath String deriving Show | ||
47 | instance Exception ProcessingException | ||
48 | |||
49 | |||
50 | data Format = | ||
51 | PictureFormat | ||
52 | | PlainTextFormat | ||
53 | | PortableDocumentFormat | ||
54 | | VideoFormat | ||
55 | | AudioFormat | ||
56 | | Unknown | ||
57 | |||
58 | formatFromPath :: Path -> Format | ||
59 | formatFromPath = | ||
60 | maybe Unknown ((fromExt . map toLower) . takeExtension) . fileName | ||
61 | where | ||
62 | fromExt :: String -> Format | ||
63 | fromExt ext = case ext of | ||
64 | ".bmp" -> PictureFormat | ||
65 | ".jpg" -> PictureFormat | ||
66 | ".jpeg" -> PictureFormat | ||
67 | ".png" -> PictureFormat | ||
68 | ".tiff" -> PictureFormat | ||
69 | ".hdr" -> PictureFormat | ||
70 | ".gif" -> PictureFormat | ||
71 | ".txt" -> PlainTextFormat | ||
72 | ".md" -> PlainTextFormat -- TODO: handle markdown separately | ||
73 | ".pdf" -> PortableDocumentFormat | ||
74 | ".wav" -> AudioFormat | ||
75 | ".oga" -> AudioFormat | ||
76 | ".ogg" -> AudioFormat | ||
77 | ".spx" -> AudioFormat | ||
78 | ".opus" -> AudioFormat | ||
79 | ".flac" -> AudioFormat | ||
80 | ".m4a" -> AudioFormat | ||
81 | ".mp3" -> AudioFormat | ||
82 | ".ogv" -> VideoFormat | ||
83 | ".ogx" -> VideoFormat | ||
84 | ".webm" -> VideoFormat | ||
85 | ".mkv" -> VideoFormat | ||
86 | ".mp4" -> VideoFormat | ||
87 | _ -> Unknown | ||
88 | |||
89 | |||
90 | type FileProcessor = | ||
91 | FileName -- ^ Input path | ||
92 | -> FileName -- ^ Output path | ||
93 | -> IO () | ||
94 | |||
95 | copyFileProcessor :: FileProcessor | ||
96 | copyFileProcessor inputPath outputPath = | ||
97 | putStrLn ("Copying:\t" ++ outputPath) | ||
98 | >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath | ||
99 | |||
100 | resizePictureUpTo :: Resolution -> FileProcessor | ||
101 | resizePictureUpTo maxResolution inputPath outputPath = | ||
102 | putStrLn ("Generating:\t" ++ outputPath) | ||
103 | >> ensureParentDir (flip resize) outputPath inputPath | ||
104 | where | ||
105 | maxSize :: Resolution -> String | ||
106 | maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">" | ||
107 | |||
108 | resize :: FileName -> FileName -> IO () | ||
109 | resize input output = callProcess "magick" | ||
110 | [ input | ||
111 | , "-auto-orient" | ||
112 | , "-resize", maxSize maxResolution | ||
113 | , output ] | ||
114 | |||
115 | |||
116 | type Cache = FileProcessor -> FileProcessor | ||
117 | |||
118 | skipCached :: Cache | ||
119 | skipCached processor inputPath outputPath = | ||
120 | removePathForcibly outputPath | ||
121 | >> processor inputPath outputPath | ||
122 | |||
123 | withCached :: Cache | ||
124 | withCached processor inputPath outputPath = | ||
125 | do | ||
126 | isDir <- doesDirectoryExist outputPath | ||
127 | when isDir $ removePathForcibly outputPath | ||
128 | |||
129 | fileExists <- doesFileExist outputPath | ||
130 | if fileExists then | ||
131 | do | ||
132 | needUpdate <- isOutdated True inputPath outputPath | ||
133 | if needUpdate then update else skip | ||
134 | else | ||
135 | update | ||
136 | |||
137 | where | ||
138 | update = processor inputPath outputPath | ||
139 | skip = putStrLn $ "Skipping:\t" ++ outputPath | ||
140 | |||
141 | |||
142 | resourceAt :: FilePath -> Path -> IO Resource | ||
143 | resourceAt fsPath resPath = Resource resPath <$> getModificationTime fsPath | ||
144 | |||
145 | getImageResolution :: FilePath -> IO Resolution | ||
146 | getImageResolution fsPath = | ||
147 | readProcess "magick" ["identify", "-format", "%w %h", firstFrame] [] | ||
148 | >>= parseResolution . break (== ' ') | ||
149 | where | ||
150 | firstFrame :: FilePath | ||
151 | firstFrame = fsPath ++ "[0]" | ||
152 | |||
153 | parseResolution :: (String, String) -> IO Resolution | ||
154 | parseResolution (widthString, heightString) = | ||
155 | case (readMaybe widthString, readMaybe heightString) of | ||
156 | (Just w, Just h) -> return $ Resolution w h | ||
157 | _ -> throwIO $ ProcessingException fsPath "Unable to read image resolution." | ||
158 | |||
159 | getPictureProps :: ItemDescriber | ||
160 | getPictureProps fsPath resource = Picture resource <$> getImageResolution fsPath | ||
161 | |||
162 | |||
163 | type ItemDescriber = | ||
164 | FilePath | ||
165 | -> Resource | ||
166 | -> IO GalleryItemProps | ||
167 | |||
168 | |||
169 | type ItemFileProcessor = | ||
170 | FileName -- ^ Input base path | ||
171 | -> FileName -- ^ Output base path | ||
172 | -> FileName -- ^ Output class (subdir) | ||
173 | -> ItemProcessor | ||
174 | |||
175 | itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor | ||
176 | itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = | ||
177 | cached processor inPath outPath | ||
178 | >> resourceAt outPath relOutPath | ||
179 | >>= descriptor outPath | ||
180 | where | ||
181 | relOutPath = resClass /> inputRes | ||
182 | inPath = localPath $ inputBase /> inputRes | ||
183 | outPath = localPath $ outputBase /> relOutPath | ||
184 | (processor, descriptor) = processorFor (formatFromPath inputRes) maxResolution | ||
185 | |||
186 | processorFor :: Format -> Maybe Resolution -> (FileProcessor, ItemDescriber) | ||
187 | processorFor PictureFormat (Just maxRes) = (resizePictureUpTo maxRes, getPictureProps) | ||
188 | processorFor PictureFormat Nothing = (copyFileProcessor, getPictureProps) | ||
189 | processorFor PlainTextFormat _ = (copyFileProcessor, const $ return . PlainText) | ||
190 | processorFor PortableDocumentFormat _ = (copyFileProcessor, const $ return . PDF) | ||
191 | processorFor VideoFormat _ = (copyFileProcessor, const $ return . Video) | ||
192 | processorFor AudioFormat _ = (copyFileProcessor, const $ return . Audio) | ||
193 | -- TODO: handle video reencoding and others? | ||
194 | processorFor Unknown _ = (copyFileProcessor, const $ return . Other) | ||
195 | |||
196 | |||
197 | type ThumbnailFileProcessor = | ||
198 | FileName -- ^ Input base path | ||
199 | -> FileName -- ^ Output base path | ||
200 | -> FileName -- ^ Output class (subdir) | ||
201 | -> ThumbnailProcessor | ||
202 | |||
203 | thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor | ||
204 | thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = | ||
205 | cached <$> processorFor (formatFromPath inputRes) | ||
206 | & process | ||
207 | where | ||
208 | relOutPath = resClass /> inputRes | ||
209 | inPath = localPath $ inputBase /> inputRes | ||
210 | outPath = localPath $ outputBase /> relOutPath | ||
211 | |||
212 | process :: Maybe FileProcessor -> IO (Maybe Thumbnail) | ||
213 | process Nothing = return Nothing | ||
214 | process (Just proc) = | ||
215 | do | ||
216 | proc inPath outPath | ||
217 | resource <- resourceAt outPath relOutPath | ||
218 | resolution <- getImageResolution outPath | ||
219 | return $ Just $ Thumbnail resource resolution | ||
220 | |||
221 | processorFor :: Format -> Maybe FileProcessor | ||
222 | processorFor PictureFormat = Just $ resizePictureUpTo maxRes | ||
223 | processorFor _ = Nothing | ||