compiler: metadata sidecar for whole directories

GitHub: closes #3

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 =
     let itemProc = itemProcessor config cache
     let thumbnailProc = thumbnailProcessor config cache
     let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config)
-    resources <- galleryBuilder (galleryName config) inputTree
+    resources <- galleryBuilder inputTree
 
     when cleanOutput $ galleryCleanupResourceDir resources outputDirPath
     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(..))
 
 
 data CompilerConfig = CompilerConfig
-  { galleryName :: String
-  , includedDirectories :: [String]
+  { includedDirectories :: [String]
   , excludedDirectories :: [String]
   , includedFiles :: [String]
   , excludedFiles :: [String]
@@ -45,8 +44,7 @@ data CompilerConfig = CompilerConfig
 
 instance FromJSON CompilerConfig where
   parseJSON = withObject "CompilerConfig" $ \v -> CompilerConfig
-    <$> v .:? "galleryName" .!= "Gallery"
-    <*> v .:? "includedDirectories" .!= ["*"]
+    <$> v .:? "includedDirectories" .!= ["*"]
     <*> v .:? "excludedDirectories" .!= []
     <*> v .:? "includedFiles" .!= ["*"]
     <*> 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 =
     | InputDir
       { path :: Path
       , modTime :: UTCTime
+      , sidecar :: Sidecar
       , dirThumbnailPath :: Maybe Path
       , items :: [InputTree] }
   deriving Show
@@ -79,6 +80,9 @@ emptySidecar = Sidecar
 sidecarExt :: String
 sidecarExt = "yaml"
 
+dirSidecar :: String
+dirSidecar = "directory." ++ sidecarExt
+
 readSidecarFile :: FilePath -> IO Sidecar
 readSidecarFile filepath =
   doesFileExist filepath
@@ -107,7 +111,8 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
       do
         dirItems <- mapM mkInputNode items
         modTime <- getModificationTime $ localPath (anchor /> path)
-        return $ InputDir path modTime (findThumbnail items) (catMaybes dirItems)
+        sidecar <- readSidecarFile $ localPath (anchor /> path </ dirSidecar)
+        return $ InputDir path modTime sidecar (findThumbnail items) (catMaybes dirItems)
 
     isSidecar :: FSNode -> Bool
     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)
 
 buildGalleryTree ::
      ItemProcessor -> ThumbnailProcessor
-  -> Int -> String -> InputTree -> IO GalleryItem
-buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree =
-  mkGalleryItem [] inputTree
+  -> Int -> InputTree -> IO GalleryItem
+buildGalleryTree processItem processThumbnail tagsFromDirectories inputTree =
+  mkGalleryItem [] [] inputTree
   where
-    mkGalleryItem :: [String] -> InputTree -> IO GalleryItem
-    mkGalleryItem parentTitles InputFile{path, modTime, sidecar} =
+    mkGalleryItem :: [String] -> [Tag] -> InputTree -> IO GalleryItem
+    mkGalleryItem parentDirs inheritedTags InputFile{path, modTime, sidecar} =
       do
         properties <- processItem path
         processedThumbnail <- processThumbnail path
         return GalleryItem
-          { title = fromMeta title $ fromMaybe "" $ fileName path
-          , datetime = fromMaybe (toZonedTime modTime) (Input.datetime sidecar)
-          , description = fromMeta description ""
-          , tags = unique ((fromMeta tags []) ++ implicitParentTags parentTitles)
+          { title = Input.title sidecar ?? fileName path ?? ""
+          , datetime = Input.datetime sidecar ?? toZonedTime modTime
+          , description = Input.description sidecar ?? ""
+          , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags parentDirs)
           , path = "/" /> path
           , thumbnail = processedThumbnail
           , properties = properties }
 
-      where
-        fromMeta :: (Sidecar -> Maybe a) -> a -> a
-        fromMeta get fallback = fromMaybe fallback $ get sidecar
-
-    mkGalleryItem parentTitles InputDir{path, modTime, dirThumbnailPath, items} =
+    mkGalleryItem parentDirs inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
       do
+        let itemsParents = (maybeToList $ fileName path) ++ parentDirs
+        let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
+        processedItems <- parallel $ map (mkGalleryItem itemsParents dirTags) items
         processedThumbnail <- maybeThumbnail dirThumbnailPath
-        processedItems <- parallel $ map (mkGalleryItem subItemsParents) items
         return GalleryItem
-          { title = fromMaybe galleryName (fileName path)
-          , datetime = fromMaybe (toZonedTime modTime) (mostRecentModTime processedItems)
-          , description = ""
-          , tags = unique (aggregateTags processedItems ++ implicitParentTags parentTitles)
+          { title = Input.title sidecar ?? fileName path ?? ""
+          , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems
+                                              ?? toZonedTime modTime
+          , description = Input.description sidecar ?? ""
+          , tags = unique (aggregateTags processedItems ++ parentDirTags parentDirs)
           , path = "/" /> path
           , thumbnail = processedThumbnail
           , properties = Directory processedItems }
 
-      where
-        subItemsParents :: [String]
-        subItemsParents = (maybeToList $ fileName path) ++ parentTitles
+    infixr ??
+    (??) :: Maybe a -> a -> a
+    (??) = flip fromMaybe
+
+    unique :: Ord a => [a] -> [a]
+    unique = Set.toList . Set.fromList
+
+    parentDirTags :: [String] -> [Tag]
+    parentDirTags = take tagsFromDirectories
+
+    aggregateTags :: [GalleryItem] -> [Tag]
+    aggregateTags = concatMap (\item -> tags (item::GalleryItem))
 
     maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail)
     maybeThumbnail Nothing = return Nothing
@@ -171,15 +179,6 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in
     comparingTime :: ZonedTime -> ZonedTime -> Ordering
     comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r)
 
-    aggregateTags :: [GalleryItem] -> [Tag]
-    aggregateTags = concatMap (\item -> tags (item::GalleryItem))
-
-    unique :: Ord a => [a] -> [a]
-    unique = Set.toList . Set.fromList
-
-    implicitParentTags :: [String] -> [Tag]
-    implicitParentTags = take tagsFromDirectories
-
     toZonedTime :: UTCTime -> ZonedTime
     toZonedTime = utcToZonedTime utc