From 395a76bc4193c0c7182f87778458a68d0079e836 Mon Sep 17 00:00:00 2001 From: pacien Date: Fri, 14 Feb 2020 15:39:56 +0100 Subject: compiler: metadata sidecar for whole directories GitHub: closes #3 --- compiler/src/Compiler.hs | 2 +- compiler/src/Config.hs | 6 ++--- compiler/src/Input.hs | 7 +++++- compiler/src/Resource.hs | 61 ++++++++++++++++++++++++------------------------ 4 files changed, 39 insertions(+), 37 deletions(-) (limited to 'compiler') 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 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 -- cgit v1.2.3