From ab2f076c5bf546f8aca9910b2b61a1b5a67361bc Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 5 Jan 2020 18:39:47 +0100 Subject: compiler: distinguish item and resource paths GitHub: closes #13 --- compiler/src/Resource.hs | 80 +++++++++++++++++++++++++++++------------------- 1 file changed, 49 insertions(+), 31 deletions(-) (limited to 'compiler/src/Resource.hs') diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index 19bd32c..2019418 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -17,7 +17,7 @@ -- along with this program. If not, see . module Resource - ( DirProcessor, ItemProcessor, ThumbnailProcessor + ( ItemProcessor, ThumbnailProcessor , GalleryItem(..), GalleryItemProps(..), Resolution(..) , buildGalleryTree, galleryCleanupResourceDir ) where @@ -27,7 +27,8 @@ import Control.Concurrent.ParallelIO.Global (parallel) import Data.List ((\\), sortBy) import Data.Ord (comparing) import Data.Char (toLower) -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (mapMaybe, fromMaybe, maybeToList) +import Data.Function ((&)) import qualified Data.Set as Set import GHC.Generics (Generic) @@ -63,8 +64,8 @@ instance ToJSON Resolution where data GalleryItemProps = Directory { items :: [GalleryItem] } - | Picture - | Other + | Picture { resource :: Path } + | Other { resource :: Path } deriving (Generic, Show) instance ToJSON GalleryItemProps where @@ -87,53 +88,60 @@ instance ToJSON GalleryItem where toEncoding = genericToEncoding encodingOptions -type DirProcessor = Path -> IO Path -type ItemProcessor = Path -> IO (Path, GalleryItemProps) +type ItemProcessor = Path -> IO GalleryItemProps type ThumbnailProcessor = Path -> IO (Maybe Path) buildGalleryTree :: - DirProcessor -> ItemProcessor -> ThumbnailProcessor + ItemProcessor -> ThumbnailProcessor -> Bool -> String -> InputTree -> IO GalleryItem -buildGalleryTree processDir processItem processThumbnail addDirTag galleryName inputTree = - mkGalleryItem Nothing inputTree >>= return . named galleryName +buildGalleryTree processItem processThumbnail addDirTag galleryName inputTree = + mkGalleryItem (Path []) inputTree >>= return . named galleryName where named :: String -> GalleryItem -> GalleryItem named name item = item { title = name } - mkGalleryItem :: Maybe String -> InputTree -> IO GalleryItem - mkGalleryItem parent InputFile{path, sidecar} = + mkGalleryItem :: Path -> InputTree -> IO GalleryItem + mkGalleryItem parents InputFile{path, sidecar} = do - (processedItemPath, properties) <- processItem path + properties <- processItem path processedThumbnail <- processThumbnail path return GalleryItem - { title = optMeta title $ fromMaybe "" $ fileName path + { title = itemTitle , date = optMeta date "" -- TODO: check and normalise dates , description = optMeta description "" - , tags = (optMeta tags []) ++ implicitParentTag parent - , path = processedItemPath + , tags = (optMeta tags []) ++ implicitParentTag parents + , path = parents Maybe a) -> a -> a optMeta get fallback = fromMaybe fallback $ get sidecar - mkGalleryItem parent InputDir{path, dirThumbnailPath, items} = + mkGalleryItem parents InputDir{path, dirThumbnailPath, items} = do - processedDir <- processDir path processedThumbnail <- maybeThumbnail dirThumbnailPath - processedItems <- parallel $ map (mkGalleryItem $ fileName path) items + processedItems <- parallel $ map (mkGalleryItem itemPath) items return GalleryItem - { title = fromMaybe "" $ fileName path + { title = itemTitle -- TODO: consider using the most recent item's date? what if empty? , date = "" -- TODO: consider allowing metadata sidecars for directories too , description = "" - , tags = (aggregateChildTags processedItems) ++ implicitParentTag parent - , path = processedDir + , tags = (aggregateChildTags processedItems) ++ implicitParentTag parents + , path = itemPath , thumbnail = processedThumbnail , properties = Directory processedItems } where + itemTitle :: String + itemTitle = fromMaybe "" $ fileName path + + itemPath :: Path + itemPath = parents IO (Maybe Path) maybeThumbnail Nothing = return Nothing maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath @@ -144,9 +152,10 @@ buildGalleryTree processDir processItem processThumbnail addDirTag galleryName i unique :: Ord a => [a] -> [a] unique = Set.toList . Set.fromList - implicitParentTag :: Maybe String -> [Tag] - implicitParentTag Nothing = [] - implicitParentTag (Just parent) = if addDirTag then [parent] else [] + implicitParentTag :: Path -> [Tag] + implicitParentTag parents + | addDirTag = maybeToList $ fileName parents + | otherwise = [] flattenGalleryTree :: GalleryItem -> [GalleryItem] @@ -157,16 +166,25 @@ flattenGalleryTree simple = [simple] galleryOutputDiff :: GalleryItem -> FSNode -> [Path] galleryOutputDiff resources ref = - (fsPaths ref) \\ (resPaths $ flattenGalleryTree resources) + (filesystemPaths ref) \\ (compiledPaths $ flattenGalleryTree resources) where - resPaths :: [GalleryItem] -> [Path] - resPaths resList = map (path::(GalleryItem->Path)) resList ++ thumbnailPaths resList + filesystemPaths :: FSNode -> [Path] + filesystemPaths = map Files.path . tail . flattenDir - thumbnailPaths :: [GalleryItem] -> [Path] - thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnail) + compiledPaths :: [GalleryItem] -> [Path] + compiledPaths items = + resourcePaths items ++ thumbnailPaths items + & concatMap subPaths - fsPaths :: FSNode -> [Path] - fsPaths = map Files.path . tail . flattenDir + resourcePaths :: [GalleryItem] -> [Path] + resourcePaths = mapMaybe (resourcePath . properties) + + resourcePath :: GalleryItemProps -> Maybe Path + resourcePath Directory{} = Nothing + resourcePath resourceProps = Just $ resource resourceProps + + thumbnailPaths :: [GalleryItem] -> [Path] + thumbnailPaths = mapMaybe thumbnail galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () -- cgit v1.2.3