diff options
Diffstat (limited to 'compiler/src')
-rw-r--r-- | compiler/src/Caching.hs | 76 | ||||
-rw-r--r-- | compiler/src/Compiler.hs | 78 | ||||
-rw-r--r-- | compiler/src/Config.hs | 6 | ||||
-rw-r--r-- | compiler/src/FileProcessors.hs | 146 | ||||
-rw-r--r-- | compiler/src/Files.hs | 36 | ||||
-rw-r--r-- | compiler/src/Input.hs | 75 | ||||
-rw-r--r-- | compiler/src/ItemProcessors.hs | 121 | ||||
-rw-r--r-- | compiler/src/Processors.hs | 203 | ||||
-rw-r--r-- | compiler/src/Resource.hs | 105 |
9 files changed, 530 insertions, 316 deletions
diff --git a/compiler/src/Caching.hs b/compiler/src/Caching.hs new file mode 100644 index 0000000..1a8b710 --- /dev/null +++ b/compiler/src/Caching.hs | |||
@@ -0,0 +1,76 @@ | |||
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 Caching | ||
20 | ( Cache | ||
21 | , noCache | ||
22 | , ItemCache | ||
23 | , buildItemCache | ||
24 | , useCached | ||
25 | ) where | ||
26 | |||
27 | |||
28 | import Control.Monad (when) | ||
29 | import qualified Data.Map.Strict as Map | ||
30 | import System.Directory (removePathForcibly, doesDirectoryExist, doesFileExist) | ||
31 | |||
32 | import FileProcessors (FileProcessor) | ||
33 | import Resource (GalleryItem(..), flattenGalleryTree) | ||
34 | import Files | ||
35 | |||
36 | |||
37 | type Cache a = FileProcessor a -> FileProcessor a | ||
38 | |||
39 | |||
40 | noCache :: Cache a | ||
41 | noCache processor itemPath resPath inputFsPath outputFsPath = | ||
42 | removePathForcibly outputFsPath | ||
43 | >> processor itemPath resPath inputFsPath outputFsPath | ||
44 | |||
45 | |||
46 | type ItemCache = Path -> Maybe GalleryItem | ||
47 | |||
48 | buildItemCache :: Maybe GalleryItem -> ItemCache | ||
49 | buildItemCache cachedItems = lookupCache | ||
50 | where | ||
51 | withKey item = (webPath $ Resource.path item, item) | ||
52 | cachedItemList = maybe [] flattenGalleryTree cachedItems | ||
53 | cachedMap = Map.fromList (map withKey cachedItemList) | ||
54 | lookupCache path = Map.lookup (webPath path) cachedMap | ||
55 | |||
56 | useCached :: ItemCache -> (GalleryItem -> Maybe a) -> Cache a | ||
57 | useCached cache propGetter processor itemPath resPath inputFsPath outputFsPath = | ||
58 | do | ||
59 | isDir <- doesDirectoryExist outputFsPath | ||
60 | when isDir $ removePathForcibly outputFsPath | ||
61 | |||
62 | fileExists <- doesFileExist outputFsPath | ||
63 | if fileExists then | ||
64 | do | ||
65 | needUpdate <- isOutdated True inputFsPath outputFsPath | ||
66 | case (needUpdate, cache itemPath >>= propGetter) of | ||
67 | (False, Just props) -> fromCache props | ||
68 | _ -> update | ||
69 | else | ||
70 | update | ||
71 | |||
72 | where | ||
73 | update = processor itemPath resPath inputFsPath outputFsPath | ||
74 | fromCache props = | ||
75 | putStrLn ("From cache:\t" ++ outputFsPath) | ||
76 | >> return props | ||
diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 749872d..d92d8e9 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs | |||
@@ -24,17 +24,25 @@ module Compiler | |||
24 | 24 | ||
25 | import GHC.Generics (Generic) | 25 | import GHC.Generics (Generic) |
26 | import Control.Monad (liftM2, when) | 26 | import Control.Monad (liftM2, when) |
27 | import Data.Bool (bool) | ||
27 | import Data.Maybe (fromMaybe) | 28 | import Data.Maybe (fromMaybe) |
28 | import System.FilePath ((</>)) | 29 | import System.FilePath ((</>)) |
29 | import qualified System.FilePath.Glob as Glob | 30 | import qualified System.FilePath.Glob as Glob |
30 | import System.Directory (canonicalizePath) | 31 | import System.Directory (canonicalizePath, doesFileExist) |
31 | 32 | ||
32 | import Data.Aeson (ToJSON) | 33 | import Data.Aeson (ToJSON, FromJSON) |
33 | import qualified Data.Aeson as JSON | 34 | import qualified Data.Aeson as JSON |
34 | 35 | ||
35 | import Config | 36 | import Config |
36 | import Input (InputTree, readInputTree, filterInputTree, sidecar, tags) | 37 | import Input (InputTree, readInputTree, filterInputTree, sidecar, tags) |
37 | import Resource (GalleryItem, buildGalleryTree, galleryCleanupResourceDir) | 38 | import Resource |
39 | ( GalleryItem | ||
40 | , GalleryItemProps | ||
41 | , Thumbnail | ||
42 | , buildGalleryTree | ||
43 | , galleryCleanupResourceDir | ||
44 | , properties | ||
45 | , thumbnail) | ||
38 | import Files | 46 | import Files |
39 | ( FileName | 47 | ( FileName |
40 | , FSNode(..) | 48 | , FSNode(..) |
@@ -43,9 +51,8 @@ import Files | |||
43 | , nodeName | 51 | , nodeName |
44 | , filterDir | 52 | , filterDir |
45 | , ensureParentDir ) | 53 | , ensureParentDir ) |
46 | import Processors | 54 | import ItemProcessors (ItemProcessor, itemFileProcessor, thumbnailFileProcessor) |
47 | ( itemFileProcessor, thumbnailFileProcessor | 55 | import Caching (Cache, noCache, buildItemCache, useCached) |
48 | , skipCached, withCached ) | ||
49 | 56 | ||
50 | 57 | ||
51 | defaultGalleryConf :: String | 58 | defaultGalleryConf :: String |
@@ -64,7 +71,7 @@ thumbnailsDir = "thumbnails" | |||
64 | data GalleryIndex = GalleryIndex | 71 | data GalleryIndex = GalleryIndex |
65 | { properties :: ViewerConfig | 72 | { properties :: ViewerConfig |
66 | , tree :: GalleryItem | 73 | , tree :: GalleryItem |
67 | } deriving (Generic, Show, ToJSON) | 74 | } deriving (Generic, Show, ToJSON, FromJSON) |
68 | 75 | ||
69 | 76 | ||
70 | writeJSON :: ToJSON a => FileName -> a -> IO () | 77 | writeJSON :: ToJSON a => FileName -> a -> IO () |
@@ -73,6 +80,16 @@ writeJSON outputPath object = | |||
73 | putStrLn $ "Generating:\t" ++ outputPath | 80 | putStrLn $ "Generating:\t" ++ outputPath |
74 | ensureParentDir JSON.encodeFile outputPath object | 81 | ensureParentDir JSON.encodeFile outputPath object |
75 | 82 | ||
83 | loadGalleryIndex :: FilePath -> IO (Maybe GalleryIndex) | ||
84 | loadGalleryIndex path = | ||
85 | doesFileExist path >>= bool (return Nothing) decodeIndex | ||
86 | where | ||
87 | decodeIndex = | ||
88 | putStrLn ("Loading previous index:\t" ++ path) | ||
89 | >> JSON.eitherDecodeFileStrict path | ||
90 | >>= either (\err -> warn err >> return Nothing) (return . Just) | ||
91 | warn = putStrLn . ("Warning:\tUnable to reuse existing index as cache: " ++) | ||
92 | |||
76 | 93 | ||
77 | (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool | 94 | (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool |
78 | (&&&) = liftM2 (&&) | 95 | (&&&) = liftM2 (&&) |
@@ -81,16 +98,16 @@ writeJSON outputPath object = | |||
81 | (|||) = liftM2 (||) | 98 | (|||) = liftM2 (||) |
82 | 99 | ||
83 | anyPattern :: [String] -> String -> Bool | 100 | anyPattern :: [String] -> String -> Bool |
84 | anyPattern patterns string = any (flip Glob.match string) (map Glob.compile patterns) | 101 | anyPattern patterns string = any (flip Glob.match string . Glob.compile) patterns |
85 | 102 | ||
86 | galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool | 103 | galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool |
87 | galleryDirFilter config excludedCanonicalDirs = | 104 | galleryDirFilter config excludedCanonicalDirs = |
88 | (not . isHidden) | 105 | (not . isHidden) |
89 | &&& (not . isExcludedDir) | 106 | &&& (not . isExcludedDir) |
90 | &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| | 107 | &&& (matchesDir (anyPattern $ includedDirectories config) ||| |
91 | (matchesFile $ anyPattern $ includedFiles config)) | 108 | matchesFile (anyPattern $ includedFiles config)) |
92 | &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) ||| | 109 | &&& (not . (matchesDir (anyPattern $ excludedDirectories config) ||| |
93 | (matchesFile $ anyPattern $ excludedFiles config))) | 110 | matchesFile (anyPattern $ excludedFiles config))) |
94 | 111 | ||
95 | where | 112 | where |
96 | matchesDir :: (FileName -> Bool) -> FSNode -> Bool | 113 | matchesDir :: (FileName -> Bool) -> FSNode -> Bool |
@@ -102,17 +119,17 @@ galleryDirFilter config excludedCanonicalDirs = | |||
102 | matchesFile _ Dir{} = False | 119 | matchesFile _ Dir{} = False |
103 | 120 | ||
104 | isExcludedDir :: FSNode -> Bool | 121 | isExcludedDir :: FSNode -> Bool |
105 | isExcludedDir Dir{canonicalPath} = any (canonicalPath ==) excludedCanonicalDirs | 122 | isExcludedDir Dir{canonicalPath} = canonicalPath `elem` excludedCanonicalDirs |
106 | isExcludedDir File{} = False | 123 | isExcludedDir File{} = False |
107 | 124 | ||
108 | inputTreeFilter :: GalleryConfig -> InputTree -> Bool | 125 | inputTreeFilter :: GalleryConfig -> InputTree -> Bool |
109 | inputTreeFilter GalleryConfig{includedTags, excludedTags} = | 126 | inputTreeFilter GalleryConfig{includedTags, excludedTags} = |
110 | (hasTagMatching $ anyPattern includedTags) | 127 | hasTagMatching (anyPattern includedTags) |
111 | &&& (not . (hasTagMatching $ anyPattern excludedTags)) | 128 | &&& (not . hasTagMatching (anyPattern excludedTags)) |
112 | 129 | ||
113 | where | 130 | where |
114 | hasTagMatching :: (String -> Bool) -> InputTree -> Bool | 131 | hasTagMatching :: (String -> Bool) -> InputTree -> Bool |
115 | hasTagMatching cond = (any cond) . (fromMaybe [""] . tags) . sidecar | 132 | hasTagMatching cond = any cond . (fromMaybe [""] . tags) . sidecar |
116 | 133 | ||
117 | 134 | ||
118 | compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO () | 135 | compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO () |
@@ -120,21 +137,27 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir | |||
120 | do | 137 | do |
121 | config <- readConfig $ inputGalleryConf configPath | 138 | config <- readConfig $ inputGalleryConf configPath |
122 | 139 | ||
140 | putStrLn "Inventorying input files" | ||
123 | inputDir <- readDirectory inputDirPath | 141 | inputDir <- readDirectory inputDirPath |
124 | excludedCanonicalDirs <- mapM canonicalizePath excludedDirs | 142 | excludedCanonicalDirs <- mapM canonicalizePath excludedDirs |
143 | |||
125 | let sourceFilter = galleryDirFilter config excludedCanonicalDirs | 144 | let sourceFilter = galleryDirFilter config excludedCanonicalDirs |
126 | let sourceTree = filterDir sourceFilter inputDir | 145 | let sourceTree = filterDir sourceFilter inputDir |
146 | putStrLn "Reading input metadata" | ||
127 | inputTree <- readInputTree sourceTree | 147 | inputTree <- readInputTree sourceTree |
128 | let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree | 148 | let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree |
129 | 149 | ||
130 | let cache = if rebuildAll then skipCached else withCached | 150 | let gall |