diff options
Diffstat (limited to 'compiler/src')
-rw-r--r-- | compiler/src/Compiler.hs | 2 | ||||
-rw-r--r-- | compiler/src/Config.hs | 6 | ||||
-rw-r--r-- | compiler/src/Input.hs | 7 | ||||
-rw-r--r-- | compiler/src/Resource.hs | 61 |
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 | ||
35 | data CompilerConfig = CompilerConfig | 35 | data 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 | ||
46 | instance FromJSON CompilerConfig where | 45 | instance 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 | |||
79 | sidecarExt :: String | 80 | sidecarExt :: String |
80 | sidecarExt = "yaml" | 81 | sidecarExt = "yaml" |
81 | 82 | ||
83 | dirSidecar :: String | ||
84 | dirSidecar = "directory." ++ sidecarExt | ||
85 | |||
82 | readSidecarFile :: FilePath -> IO Sidecar | 86 | readSidecarFile :: FilePath -> IO Sidecar |
83 | readSidecarFile filepath = | 87 | readSidecarFile 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 | ||
122 | buildGalleryTree :: | 122 | buildGalleryTree :: |
123 | ItemProcessor -> ThumbnailProcessor | 123 | ItemProcessor -> ThumbnailProcessor |
124 | -> Int -> String -> InputTree -> IO GalleryItem | 124 | -> Int -> InputTree -> IO GalleryItem |
125 | buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree = | 125 | buildGalleryTree 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 | ||