aboutsummaryrefslogtreecommitdiff
path: root/compiler/src
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src')
-rw-r--r--compiler/src/Compiler.hs2
-rw-r--r--compiler/src/Config.hs6
-rw-r--r--compiler/src/Input.hs7
-rw-r--r--compiler/src/Resource.hs61
4 files changed, 39 insertions, 37 deletions
diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index 2a0dccc..bfefa63 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -116,7 +116,7 @@ compileGallery inputDirPath outputDirPath excludedDirs rebuildAll cleanOutput =
116 let itemProc = itemProcessor config cache 116 let itemProc = itemProcessor config cache
117 let thumbnailProc = thumbnailProcessor config cache 117 let thumbnailProc = thumbnailProcessor config cache
118 let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config) 118 let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config)
119 resources <- galleryBuilder (galleryName config) inputTree 119 resources <- galleryBuilder inputTree
120 120
121 when cleanOutput $ galleryCleanupResourceDir resources outputDirPath 121 when cleanOutput $ galleryCleanupResourceDir resources outputDirPath
122 writeJSON outputIndex resources 122 writeJSON outputIndex resources
diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs
index 4c9aa40..4826f17 100644
--- a/compiler/src/Config.hs
+++ b/compiler/src/Config.hs
@@ -33,8 +33,7 @@ import Resource (Resolution(..))
33 33
34 34
35data CompilerConfig = CompilerConfig 35data CompilerConfig = CompilerConfig
36 { galleryName :: String 36 { includedDirectories :: [String]
37 , includedDirectories :: [String]
38 , excludedDirectories :: [String] 37 , excludedDirectories :: [String]
39 , includedFiles :: [String] 38 , includedFiles :: [String]
40 , excludedFiles :: [String] 39 , excludedFiles :: [String]
@@ -45,8 +44,7 @@ data CompilerConfig = CompilerConfig
45 44
46instance FromJSON CompilerConfig where 45instance FromJSON CompilerConfig where
47 parseJSON = withObject "CompilerConfig" $ \v -> CompilerConfig 46 parseJSON = withObject "CompilerConfig" $ \v -> CompilerConfig
48 <$> v .:? "galleryName" .!= "Gallery" 47 <$> v .:? "includedDirectories" .!= ["*"]
49 <*> v .:? "includedDirectories" .!= ["*"]
50 <*> v .:? "excludedDirectories" .!= [] 48 <*> v .:? "excludedDirectories" .!= []
51 <*> v .:? "includedFiles" .!= ["*"] 49 <*> v .:? "includedFiles" .!= ["*"]
52 <*> v .:? "excludedFiles" .!= [] 50 <*> v .:? "excludedFiles" .!= []
diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index cb837e3..e0fc8ef 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -58,6 +58,7 @@ data InputTree =
58 | InputDir 58 | InputDir
59 { path :: Path 59 { path :: Path
60 , modTime :: UTCTime 60 , modTime :: UTCTime
61 , sidecar :: Sidecar
61 , dirThumbnailPath :: Maybe Path 62 , dirThumbnailPath :: Maybe Path
62 , items :: [InputTree] } 63 , items :: [InputTree] }
63 deriving Show 64 deriving Show
@@ -79,6 +80,9 @@ emptySidecar = Sidecar
79sidecarExt :: String 80sidecarExt :: String
80sidecarExt = "yaml" 81sidecarExt = "yaml"
81 82
83dirSidecar :: String
84dirSidecar = "directory." ++ sidecarExt
85
82readSidecarFile :: FilePath -> IO Sidecar 86readSidecarFile :: FilePath -> IO Sidecar
83readSidecarFile filepath = 87readSidecarFile filepath =
84 doesFileExist filepath 88 doesFileExist filepath
@@ -107,7 +111,8 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
107 do 111 do
108 dirItems <- mapM mkInputNode items 112 dirItems <- mapM mkInputNode items
109 modTime <- getModificationTime $ localPath (anchor /> path) 113 modTime <- getModificationTime $ localPath (anchor /> path)
110 return $ InputDir path modTime (findThumbnail items) (catMaybes dirItems) 114 sidecar <- readSidecarFile $ localPath (anchor /> path </ dirSidecar)
115 return $ InputDir path modTime sidecar (findThumbnail items) (catMaybes dirItems)
111 116
112 isSidecar :: FSNode -> Bool 117 isSidecar :: FSNode -> Bool
113 isSidecar Dir{} = False 118 isSidecar Dir{} = False
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 400e18a..aadf60b 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -121,44 +121,52 @@ type ThumbnailProcessor = Path -> IO (Maybe Thumbnail)
121 121
122buildGalleryTree :: 122buildGalleryTree ::
123 ItemProcessor -> ThumbnailProcessor 123 ItemProcessor -> ThumbnailProcessor
124 -> Int -> String -> InputTree -> IO GalleryItem 124 -> Int -> InputTree -> IO GalleryItem
125buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree = 125buildGalleryTree processItem processThumbnail tagsFromDirectories inputTree =
126 mkGalleryItem [] inputTree 126 mkGalleryItem [] [] inputTree
127 where 127 where
128 mkGalleryItem :: [String] -> InputTree -> IO GalleryItem 128 mkGalleryItem :: [String] -> [Tag] -> InputTree -> IO GalleryItem
129 mkGalleryItem parentTitles InputFile{path, modTime, sidecar} = 129 mkGalleryItem parentDirs inheritedTags InputFile{path, modTime, sidecar} =
130 do 130 do
131 properties <- processItem path 131 properties <- processItem path
132 processedThumbnail <- processThumbnail path 132 processedThumbnail <- processThumbnail path
133 return GalleryItem 133 return GalleryItem
134 { title = fromMeta title $ fromMaybe "" $ fileName path 134 { title = Input.title sidecar ?? fileName path ?? ""
135 , datetime = fromMaybe (toZonedTime modTime) (Input.datetime sidecar) 135 , datetime = Input.datetime sidecar ?? toZonedTime modTime
136 , description = fromMeta description "" 136 , description = Input.description sidecar ?? ""
137 , tags = unique ((fromMeta tags []) ++ implicitParentTags parentTitles) 137 , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags parentDirs)
138 , path = "/" /> path 138 , path = "/" /> path
139 , thumbnail = processedThumbnail 139 , thumbnail = processedThumbnail
140 , properties = properties } 140 , properties = properties }
141 141
142 where 142 mkGalleryItem parentDirs inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
143 fromMeta :: (Sidecar -> Maybe a) -> a -> a
144 fromMeta get fallback = fromMaybe fallback $ get sidecar
145
146 mkGalleryItem parentTitles InputDir{path, modTime, dirThumbnailPath, items} =
147 do 143 do
144 let itemsParents = (maybeToList $ fileName path) ++ parentDirs
145 let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
146 processedItems <- parallel $ map (mkGalleryItem itemsParents dirTags) items
148 processedThumbnail <- maybeThumbnail dirThumbnailPath 147 processedThumbnail <- maybeThumbnail dirThumbnailPath
149 processedItems <- parallel $ map (mkGalleryItem subItemsParents) items
150 return GalleryItem 148 return GalleryItem
151 { title = fromMaybe galleryName (fileName path) 149 { title = Input.title sidecar ?? fileName path ?? ""
152 , datetime = fromMaybe (toZonedTime modTime) (mostRecentModTime processedItems) 150 , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems
153 , description = "" 151 ?? toZonedTime modTime
154 , tags = unique (aggregateTags processedItems ++ implicitParentTags parentTitles) 152 , description = Input.description sidecar ?? ""
153 , tags = unique (aggregateTags processedItems ++ parentDirTags parentDirs)
155 , path = "/" /> path 154 , path = "/" /> path
156 , thumbnail = processedThumbnail 155 , thumbnail = processedThumbnail
157 , properties = Directory processedItems } 156 , properties = Directory processedItems }
158 157
159 where 158 infixr ??
160 subItemsParents :: [String] 159 (??) :: Maybe a -> a -> a
161 subItemsParents = (maybeToList $ fileName path) ++ parentTitles 160 (??) = flip fromMaybe
161
162 unique :: Ord a => [a] -> [a]
163 unique = Set.toList . Set.fromList
164
165 parentDirTags :: [String] -> [Tag]
166 parentDirTags = take tagsFromDirectories
167
168 aggregateTags :: [GalleryItem] -> [Tag]
169 aggregateTags = concatMap (\item -> tags (item::GalleryItem))
162 170
163 maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail) 171 maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail)
164 maybeThumbnail Nothing = return Nothing 172 maybeThumbnail Nothing = return Nothing
@@ -171,15 +179,6 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in
171 comparingTime :: ZonedTime -> ZonedTime -> Ordering 179 comparingTime :: ZonedTime -> ZonedTime -> Ordering
172 comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r) 180 comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r)
173 181
174 aggregateTags :: [GalleryItem] -> [Tag]
175 aggregateTags = concatMap (\item -> tags (item::GalleryItem))
176
177 unique :: Ord a => [a] -> [a]
178 unique = Set.toList . Set.fromList
179
180 implicitParentTags :: [String] -> [Tag]
181 implicitParentTags = take tagsFromDirectories
182
183 toZonedTime :: UTCTime -> ZonedTime 182 toZonedTime :: UTCTime -> ZonedTime
184 toZonedTime = utcToZonedTime utc 183 toZonedTime = utcToZonedTime utc
185 184