1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
-- ldgallery - A static generator which turns a collection of tagged
-- pictures into a searchable web gallery.
--
-- Copyright (C) 2019-2022 Pacien TRAN-GIRARD
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <https://www.gnu.org/licenses/>.
module FileProcessors
( FileProcessor
, transformThenDescribe
, copyResource
, noopProcessor
, FileTransformer
, copyFileProcessor
, resizePictureUpTo
, resourceAt
, getImageResolution
, FileDescriber
, getResProps
, getPictureProps
, getThumbnailProps
) where
import Control.Exception (Exception, throwIO)
import System.Process (readProcess, callProcess)
import Text.Read (readMaybe)
import System.Directory (getModificationTime)
import qualified System.Directory
import Config (Resolution(..))
import Resource (Resource(..), GalleryItemProps(..), Thumbnail(..))
import Files
data ProcessingException = ProcessingException FilePath String deriving Show
instance Exception ProcessingException
type FileProcessor a =
Path -- ^ Item path
-> Path -- ^ Target resource path
-> FilePath -- ^ Filesystem input path
-> FilePath -- ^ Filesystem output path
-> IO a
transformThenDescribe :: FileTransformer -> FileDescriber a -> FileProcessor a
transformThenDescribe transformer describer _itemPath resPath fsInPath fsOutPath =
transformer fsInPath fsOutPath >> describer resPath fsOutPath
copyResource :: (Resource -> a) -> FileProcessor a
copyResource resPropConstructor =
transformThenDescribe copyFileProcessor (getResProps resPropConstructor)
noopProcessor :: FileProcessor (Maybe a)
noopProcessor _ _ _ _ = return Nothing
type FileTransformer =
FileName -- ^ Input path
-> FileName -- ^ Output path
-> IO ()
copyFileProcessor :: FileTransformer
copyFileProcessor inputPath outputPath =
putStrLn ("Copying:\t" ++ outputPath)
>> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath
resizePictureUpTo :: Resolution -> FileTransformer
resizePictureUpTo maxResolution inputPath outputPath =
putStrLn ("Processing:\t" ++ outputPath)
>> ensureParentDir (flip resize) outputPath inputPath
where
maxSize :: Resolution -> String
maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">"
resize :: FileName -> FileName -> IO ()
resize input output = callProcess "magick"
[ input
, "-auto-orient"
, "-resize", maxSize maxResolution
, output ]
type FileDescriber a =
Path -- ^ Target resource path
-> FilePath -- ^ Filesystem path
-> IO a
getImageResolution :: FilePath -> IO Resolution
getImageResolution fsPath =
readProcess "magick"
[ "identify"
, "-ping"
, "-format", "%[orientation] %w %h"
, firstFrame
] []
>>= parseOutput . words
where
firstFrame :: FilePath
firstFrame = fsPath ++ "[0]"
-- Flip the dimensions when necessary according to the metadata.
-- ImageMagick's `-auto-orient` flag does the same, but isn't compatible
-- with `-ping` and causes the whole image file to be loaded.
parseOutput :: [String] -> IO Resolution
parseOutput ["RightTop", w, h] = parseResolution (h, w)
parseOutput ["LeftBottom", w, h] = parseResolution (h, w)
parseOutput [_, w, h] = parseResolution (w, h)
parseOutput _ = throwIO failedRead
parseResolution :: (String, String) -> IO Resolution
parseResolution (widthString, heightString) =
case (readMaybe widthString, readMaybe heightString) of
(Just w, Just h) -> return $ Resolution w h
_ -> throwIO failedRead
failedRead :: ProcessingException
failedRead = ProcessingException fsPath "Unable to read image resolution."
resourceAt :: FileDescriber Resource
resourceAt resPath fsPath = Resource resPath <$> getModificationTime fsPath
getResProps :: (Resource -> a) -> FileDescriber a
getResProps resPropsConstructor resPath fsPath =
resPropsConstructor <$> resourceAt resPath fsPath
getPictureProps :: FileDescriber GalleryItemProps
getPictureProps resPath fsPath =
Picture <$> resourceAt resPath fsPath <*> getImageResolution fsPath
getThumbnailProps :: FileDescriber (Maybe Thumbnail)
getThumbnailProps resPath fsPath =
Just <$> (Thumbnail <$> resourceAt resPath fsPath <*> getImageResolution fsPath)
|