aboutsummaryrefslogtreecommitdiff
path: root/compiler/src
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src')
-rw-r--r--compiler/src/Caching.hs76
-rw-r--r--compiler/src/Compiler.hs74
-rw-r--r--compiler/src/Config.hs6
-rw-r--r--compiler/src/FileProcessors.hs128
-rw-r--r--compiler/src/Files.hs36
-rw-r--r--compiler/src/Input.hs65
-rw-r--r--compiler/src/ItemProcessors.hs115
-rw-r--r--compiler/src/Processors.hs203
-rw-r--r--compiler/src/Resource.hs90
9 files changed, 492 insertions, 301 deletions
diff --git a/compiler/src/Caching.hs b/compiler/src/Caching.hs
new file mode 100644
index 0000000..c2b5a43
--- /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
19module Caching
20 ( Cache
21 , noCache
22 , ItemCache
23 , buildItemCache
24 , useCached
25 ) where
26
27
28import Control.Monad (when)
29import qualified Data.Map.Strict as Map
30import System.Directory (removePathForcibly, doesDirectoryExist, doesFileExist)
31
32import FileProcessors (FileProcessor)
33import Resource (GalleryItem(..), flattenGalleryTree)
34import Files
35
36
37type Cache a = FileProcessor a -> FileProcessor a
38
39
40noCache :: Cache a
41noCache processor itemPath resPath inputFsPath outputFsPath =
42 removePathForcibly outputFsPath
43 >> processor itemPath resPath inputFsPath outputFsPath
44
45
46type ItemCache = Path -> Maybe GalleryItem
47
48buildItemCache :: Maybe GalleryItem -> ItemCache
49buildItemCache 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
56useCached :: ItemCache -> (GalleryItem -> a) -> Cache a
57useCached 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) 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 (propGetter props)
diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index 749872d..1ec55c5 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -24,17 +24,25 @@ module Compiler
24 24
25import GHC.Generics (Generic) 25import GHC.Generics (Generic)
26import Control.Monad (liftM2, when) 26import Control.Monad (liftM2, when)
27import Data.Bool (bool)
27import Data.Maybe (fromMaybe) 28import Data.Maybe (fromMaybe)
28import System.FilePath ((</>)) 29import System.FilePath ((</>))
29import qualified System.FilePath.Glob as Glob 30import qualified System.FilePath.Glob as Glob
30import System.Directory (canonicalizePath) 31import System.Directory (canonicalizePath, doesFileExist)
31 32
32import Data.Aeson (ToJSON) 33import Data.Aeson (ToJSON, FromJSON)
33import qualified Data.Aeson as JSON 34import qualified Data.Aeson as JSON
34 35
35import Config 36import Config
36import Input (InputTree, readInputTree, filterInputTree, sidecar, tags) 37import Input (InputTree, readInputTree, filterInputTree, sidecar, tags)
37import Resource (GalleryItem, buildGalleryTree, galleryCleanupResourceDir) 38import Resource
39 ( GalleryItem
40 , GalleryItemProps
41 , Thumbnail
42 , buildGalleryTree
43 , galleryCleanupResourceDir
44 , properties
45 , thumbnail)
38import Files 46import 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 )
46import Processors 54import ItemProcessors (ItemProcessor, itemFileProcessor, thumbnailFileProcessor)
47 ( itemFileProcessor, thumbnailFileProcessor 55import Caching (Cache, noCache, buildItemCache, useCached)
48 , skipCached, withCached )
49 56
50 57
51defaultGalleryConf :: String 58defaultGalleryConf :: String
@@ -64,7 +71,7 @@ thumbnailsDir = "thumbnails"
64data GalleryIndex = GalleryIndex 71data 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
70writeJSON :: ToJSON a => FileName -> a -> IO () 77writeJSON :: ToJSON a => FileName -> a -> IO ()
@@ -73,6 +80,15 @@ 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
83loadGalleryIndex :: FilePath -> IO (Maybe GalleryIndex)
84loadGalleryIndex path =
85 doesFileExist path >>= bool (return Nothing) decodeIndex
86 where
87 decodeIndex =
88 JSON.eitherDecodeFileStrict path
89 >>= either (\err -> warn err >> return Nothing) (return . Just)
90 warn = putStrLn . ("Warning:\tUnable to reuse existing index as cache: " ++)
91
76 92
77(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool 93(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
78(&&&) = liftM2 (&&) 94(&&&) = liftM2 (&&)
@@ -81,16 +97,16 @@ writeJSON outputPath object =
81(|||) = liftM2 (||) 97(|||) = liftM2 (||)
82 98
83anyPattern :: [String] -> String -> Bool 99anyPattern :: [String] -> String -> Bool
84anyPattern patterns string = any (flip Glob.match string) (map Glob.compile patterns) 100anyPattern patterns string = any (flip Glob.match string . Glob.compile) patterns
85 101
86galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool 102galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool
87galleryDirFilter config excludedCanonicalDirs = 103galleryDirFilter config excludedCanonicalDirs =
88 (not . isHidden) 104 (not . isHidden)
89 &&& (not . isExcludedDir) 105 &&& (not . isExcludedDir)
90 &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| 106 &&& (matchesDir (anyPattern $ includedDirectories config) |||
91 (matchesFile $ anyPattern $ includedFiles config)) 107 matchesFile (anyPattern $ includedFiles config))
92 &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) ||| 108 &&& (not . (matchesDir (anyPattern $ excludedDirectories config) |||
93 (matchesFile $ anyPattern $ excludedFiles config))) 109 matchesFile (anyPattern $ excludedFiles config)))
94 110
95 where 111 where
96 matchesDir :: (FileName -> Bool) -> FSNode -> Bool 112 matchesDir :: (FileName -> Bool) -> FSNode -> Bool
@@ -102,17 +118,17 @@ galleryDirFilter config excludedCanonicalDirs =
102 matchesFile _ Dir{} = False 118 matchesFile _ Dir{} = False
103 119
104 isExcludedDir :: FSNode -> Bool 120 isExcludedDir :: FSNode -> Bool
105 isExcludedDir Dir{canonicalPath} = any (canonicalPath ==) excludedCanonicalDirs 121 isExcludedDir Dir{canonicalPath} = canonicalPath `elem` excludedCanonicalDirs
106 isExcludedDir File{} = False 122 isExcludedDir File{} = False
107 123
108inputTreeFilter :: GalleryConfig -> InputTree -> Bool 124inputTreeFilter :: GalleryConfig -> InputTree -> Bool
109inputTreeFilter GalleryConfig{includedTags, excludedTags} = 125inputTreeFilter GalleryConfig{includedTags, excludedTags} =
110 (hasTagMatching $ anyPattern includedTags) 126 hasTagMatching (anyPattern includedTags)
111 &&& (not . (hasTagMatching $ anyPattern excludedTags)) 127 &&& (not . hasTagMatching (anyPattern excludedTags))
112 128
113 where 129 where
114 hasTagMatching :: (String -> Bool) -> InputTree -> Bool 130 hasTagMatching :: (String -> Bool) -> InputTree -> Bool
115 hasTagMatching cond = (any cond) . (fromMaybe [""] . tags) . sidecar 131 hasTagMatching cond = any cond . (fromMaybe [""] . tags) . sidecar
116 132
117 133
118compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO () 134compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO ()
@@ -127,14 +143,17 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir
127 inputTree <- readInputTree sourceTree 143 inputTree <- readInputTree sourceTree
128 let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree 144 let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree
129 145
130 let cache = if rebuildAll then skipCached else withCached 146 let galleryIndexPath = outputGalleryIndex outputIndexPath
131 let itemProc = itemProcessor config cache 147 cachedIndex <- loadCachedIndex galleryIndexPath
132 let thumbnailProc = thumbnailProcessor config cache 148 let cache = mkCache cachedIndex
149
150 let itemProc = itemProcessor config (cache Resource.properties)
151 let thumbnailProc = thumbnailProcessor config (cache Resource.thumbnail)
133 let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config) 152 let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config)
134 resources <- galleryBuilder curatedInputTree 153 resources <- galleryBuilder curatedInputTree
135 154
136 when cleanOutput $ galleryCleanupResourceDir resources outputDirPath 155 when cleanOutput $ galleryCleanupResourceDir resources outpu