diff options
author | pacien | 2020-09-25 16:01:49 +0200 |
---|---|---|
committer | pacien | 2020-09-25 16:01:49 +0200 |
commit | e93f7b1eb84c083d67567115284c0002a3a7d5fc (patch) | |
tree | 8d373e8f7f571485e1330928f43b090ed004c525 /compiler/src/Processors.hs | |
parent | 8e3ac8fe44bebb38e1882ca7f06b8100078ad88d (diff) | |
parent | fd542f75a1d94ee5f804d0925823276b97f38581 (diff) | |
download | ldgallery-e93f7b1eb84c083d67567115284c0002a3a7d5fc.tar.gz |
Merge branch 'develop' for release v2.0v2.0
Diffstat (limited to 'compiler/src/Processors.hs')
-rw-r--r-- | compiler/src/Processors.hs | 203 |
1 files changed, 0 insertions, 203 deletions
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs deleted file mode 100644 index 02db325..0000000 --- a/compiler/src/Processors.hs +++ /dev/null | |||
@@ -1,203 +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 | -- TODO: handle video, music, text... | ||
51 | data Format = PictureFormat | Unknown | ||
52 | |||
53 | formatFromPath :: Path -> Format | ||
54 | formatFromPath = | ||
55 | maybe Unknown fromExt | ||
56 | . fmap (map toLower) | ||
57 | . fmap takeExtension | ||
58 | . fileName | ||
59 | where | ||
60 | fromExt :: String -> Format | ||
61 | fromExt ext = case ext of | ||
62 | ".bmp" -> PictureFormat | ||
63 | ".jpg" -> PictureFormat | ||
64 | ".jpeg" -> PictureFormat | ||
65 | ".png" -> PictureFormat | ||
66 | ".tiff" -> PictureFormat | ||
67 | ".hdr" -> PictureFormat | ||
68 | ".gif" -> PictureFormat | ||
69 | _ -> Unknown | ||
70 | |||
71 | |||
72 | type FileProcessor = | ||
73 | FileName -- ^ Input path | ||
74 | -> FileName -- ^ Output path | ||
75 | -> IO () | ||
76 | |||
77 | copyFileProcessor :: FileProcessor | ||
78 | copyFileProcessor inputPath outputPath = | ||
79 | (putStrLn $ "Copying:\t" ++ outputPath) | ||
80 | >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath | ||
81 | |||
82 | resizePictureUpTo :: Resolution -> FileProcessor | ||
83 | resizePictureUpTo maxResolution inputPath outputPath = | ||
84 | (putStrLn $ "Generating:\t" ++ outputPath) | ||
85 | >> ensureParentDir (flip resize) outputPath inputPath | ||
86 | where | ||
87 | maxSize :: Resolution -> String | ||
88 | maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">" | ||
89 | |||
90 | resize :: FileName -> FileName -> IO () | ||
91 | resize input output = callProcess "magick" | ||
92 | [ input | ||
93 | , "-auto-orient" | ||
94 | , "-resize", maxSize maxResolution | ||
95 | , output ] | ||
96 | |||
97 | |||
98 | type Cache = FileProcessor -> FileProcessor | ||
99 | |||
100 | skipCached :: Cache | ||
101 | skipCached processor inputPath outputPath = | ||
102 | removePathForcibly outputPath | ||
103 | >> processor inputPath outputPath | ||
104 | |||
105 | withCached :: Cache | ||
106 | withCached processor inputPath outputPath = | ||
107 | do | ||
108 | isDir <- doesDirectoryExist outputPath | ||
109 | when isDir $ removePathForcibly outputPath | ||
110 | |||
111 | fileExists <- doesFileExist outputPath | ||
112 | if fileExists then | ||
113 | do | ||
114 | needUpdate <- isOutdated True inputPath outputPath | ||
115 | if needUpdate then update else skip | ||
116 | else | ||
117 | update | ||
118 | |||
119 | where | ||
120 | update = processor inputPath outputPath | ||
121 | skip = putStrLn $ "Skipping:\t" ++ outputPath | ||
122 | |||
123 | |||
124 | resourceAt :: FilePath -> Path -> IO Resource | ||
125 | resourceAt fsPath resPath = getModificationTime fsPath >>= return . Resource resPath | ||
126 | |||
127 | getImageResolution :: FilePath -> IO Resolution | ||
128 | getImageResolution 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 | |||
141 | getPictureProps :: ItemDescriber | ||
142 | getPictureProps fsPath resource = | ||
143 | getImageResolution fsPath | ||
144 | >>= return . Picture resource | ||
145 | |||
146 | |||
147 | type ItemDescriber = | ||
148 | FilePath | ||
149 | -> Resource | ||
150 | -> IO GalleryItemProps | ||
151 | |||
152 | |||
153 | type ItemFileProcessor = | ||
154 | FileName -- ^ Input base path | ||
155 | -> FileName -- ^ Output base path | ||
156 | -> FileName -- ^ Output class (subdir) | ||
157 | -> ItemProcessor | ||
158 | |||
159 | itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor | ||
160 | itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = | ||
161 | cached processor inPath outPath | ||
162 | >> resourceAt outPath relOutPath | ||
163 | >>= descriptor outPath | ||
164 | where | ||
165 | relOutPath = resClass /> inputRes | ||
166 | inPath = localPath $ inputBase /> inputRes | ||
167 | outPath = localPath $ outputBase /> relOutPath | ||
168 | (processor, descriptor) = processorFor (formatFromPath inputRes) maxResolution | ||
169 | |||
170 | processorFor :: Format -> Maybe Resolution -> (FileProcessor, ItemDescriber) | ||
171 | processorFor PictureFormat (Just maxRes) = (resizePictureUpTo maxRes, getPictureProps) | ||
172 | processorFor PictureFormat Nothing = (copyFileProcessor, getPictureProps) | ||
173 | -- TODO: handle video reencoding and others? | ||
174 | processorFor Unknown _ = (copyFileProcessor, const $ return . Other) | ||
175 | |||
176 | |||
177 | type ThumbnailFileProcessor = | ||
178 | FileName -- ^ Input base path | ||
179 | -> FileName -- ^ Output base path | ||
180 | -> FileName -- ^ Output class (subdir) | ||
181 | -> ThumbnailProcessor | ||
182 | |||
183 | thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor | ||
184 | thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = | ||
185 | cached <$> processorFor (formatFromPath inputRes) | ||
186 | & process | ||
187 | where | ||
188 | relOutPath = resClass /> inputRes | ||
189 | inPath = localPath $ inputBase /> inputRes | ||
190 | outPath = localPath $ outputBase /> relOutPath | ||
191 | |||
192 | process :: Maybe FileProcessor -> IO (Maybe Thumbnail) | ||
193 | process Nothing = return Nothing | ||
194 | process (Just proc) = | ||
195 | do | ||
196 | proc inPath outPath | ||
197 | resource <- resourceAt outPath relOutPath | ||
198 | resolution <- getImageResolution outPath | ||
199 | return $ Just $ Thumbnail resource resolution | ||
200 | |||
201 | processorFor :: Format -> Maybe FileProcessor | ||
202 | processorFor PictureFormat = Just $ resizePictureUpTo maxRes | ||
203 | processorFor _ = Nothing | ||