From d0962ef2dea7e8a0c25ca8fdbc55fcbafeeb2f79 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 30 Dec 2019 23:18:49 +0100 Subject: compiler: refactor resource transformation pipeline --- compiler/src/Compiler.hs | 17 ++--- compiler/src/Config.hs | 2 +- compiler/src/Gallery.hs | 134 -------------------------------- compiler/src/Input.hs | 2 +- compiler/src/Processors.hs | 8 +- compiler/src/Resource.hs | 185 +++++++++++++++++++++++++++++++-------------- 6 files changed, 138 insertions(+), 210 deletions(-) delete mode 100644 compiler/src/Gallery.hs (limited to 'compiler/src') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 0a3e540..048afc1 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -37,8 +37,7 @@ import qualified Data.Aeson as JSON import Config import Input (decodeYamlFile, readInputTree) -import Resource (ResourceTree, buildResourceTree, cleanupResourceDir) -import Gallery (buildGallery) +import Resource (GalleryItem, buildGalleryTree, galleryCleanupResourceDir) import Files ( FileName , FSNode(..) @@ -75,17 +74,15 @@ compileGallery inputDirPath outputDirPath rebuildAll = invalidateCache <- isOutdated False inputGalleryConf outputIndex let cache = if invalidateCache || rebuildAll then skipCached else withCached + let itemProc = itemProcessor (pictureMaxResolution config) cache let thumbnailProc = thumbnailProcessor (thumbnailResolution config) cache - resourceTree <- buildResourceTree dirProcessor itemProc thumbnailProc inputTree - - cleanupResourceDir resourceTree outputDirPath - - buildGallery (galleryName config) resourceTree - & writeJSON outputIndex + let galleryBuilder = buildGalleryTree dirProcessor itemProc thumbnailProc + resources <- galleryBuilder (galleryName config) inputTree - viewer fullConfig - & writeJSON outputViewerConf + galleryCleanupResourceDir resources outputDirPath + writeJSON outputIndex resources + writeJSON outputViewerConf $ viewer fullConfig where galleryConf = "gallery.yaml" diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index 044a155..c75ab01 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -37,7 +37,7 @@ import qualified Data.Aeson as JSON import Files (FileName) import Input (decodeYamlFile) -import Processors (Resolution(..)) +import Resource (Resolution(..)) data CompilerConfig = CompilerConfig diff --git a/compiler/src/Gallery.hs b/compiler/src/Gallery.hs deleted file mode 100644 index a1b1674..0000000 --- a/compiler/src/Gallery.hs +++ /dev/null @@ -1,134 +0,0 @@ --- ldgallery - A static generator which turns a collection of tagged --- pictures into a searchable web gallery. --- --- Copyright (C) 2019 Pacien TRAN-GIRARD --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as --- published by the Free Software Foundation, either version 3 of the --- License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE - DuplicateRecordFields - , DeriveGeneric - , DeriveAnyClass -#-} - -module Gallery - ( GalleryItem(..), buildGallery - ) where - - -import GHC.Generics (Generic) -import Data.Char (toLower) -import Data.Function ((&)) -import Data.Maybe (fromMaybe) - -import Data.Aeson (ToJSON, genericToJSON, genericToEncoding) -import qualified Data.Aeson as JSON - -import qualified Data.Set as Set - -import Files -import Input -import Resource - - -encodingOptions :: JSON.Options -encodingOptions = JSON.defaultOptions - { JSON.fieldLabelModifier = map toLower - , JSON.constructorTagModifier = map toLower - , JSON.sumEncoding = JSON.defaultTaggedObject - { JSON.tagFieldName = "type" - , JSON.contentsFieldName = "contents" - } - } - - -type ResourcePath = String -type Tag = String -type FileSizeKB = Int - - -data Resolution = Resolution - { width :: Int - , height :: Int - } deriving (Generic, Show) - -instance ToJSON Resolution where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions - - -data GalleryItemProps = - Directory { items :: [GalleryItem] } --- | Image { resolution :: Resolution, filesize :: FileSizeKB } --- | Video { filesize :: FileSizeKB } - | Unknown - deriving (Generic, Show) - -instance ToJSON GalleryItemProps where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions - - --- TODO: fuse GalleryItem and GalleryItemProps -data GalleryItem = GalleryItem - { title :: String - , date :: String -- TODO: checked ISO8601 date - , description :: String - , tags :: [Tag] - , path :: Path - , thumbnail :: Maybe Path - , properties :: GalleryItemProps - } deriving (Generic, Show) - -instance ToJSON GalleryItem where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions - - -buildGalleryTree :: ResourceTree -> GalleryItem -buildGalleryTree (ItemResource sidecar path thumbnail) = - GalleryItem - { title = optMeta title $ fileName path - , date = optMeta date "" -- TODO: check and normalise dates - , description = optMeta description "" - , tags = optMeta tags [] - , path = path - , thumbnail = thumbnail - , properties = Unknown } -- TODO - where - optMeta :: (Sidecar -> Maybe a) -> a -> a - optMeta get fallback = fromMaybe fallback $ get sidecar - -buildGalleryTree (DirResource dirItems path thumbnail) = - map buildGalleryTree dirItems - & \items -> GalleryItem - { title = fileName path - -- TODO: consider using the most recent item's date? what if empty? - , date = "" - -- TODO: consider allowing metadata sidecars for directories too - , description = "" - , tags = aggregateChildTags items - , path = path - , thumbnail = thumbnail - , properties = Directory items } - where - aggregateChildTags :: [GalleryItem] -> [Tag] - aggregateChildTags = unique . concatMap (\item -> tags (item::GalleryItem)) - - unique :: Ord a => [a] -> [a] - unique = Set.toList . Set.fromList - -buildGallery :: String -> ResourceTree -> GalleryItem -buildGallery galleryName resourceTree = - (buildGalleryTree resourceTree) { title = galleryName } diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index cb9fc60..2e11ebe 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -24,7 +24,7 @@ module Input ( decodeYamlFile - , Sidecar, title, date, description, tags + , Sidecar(..) , InputTree(..), readInputTree ) where diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index ded3cc5..df05c24 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -37,9 +37,6 @@ import Data.Function ((&)) import Data.Ratio ((%)) import Data.Char (toLower) -import GHC.Generics (Generic) -import Data.Aeson (FromJSON) - import System.Directory hiding (copyFile) import qualified System.Directory import System.FilePath @@ -60,7 +57,7 @@ data Format = | Other formatFromPath :: Path -> Format -formatFromPath = aux . (map toLower) . fileName +formatFromPath = aux . (map toLower) . takeExtension . fileName where aux ".bmp" = Bmp aux ".jpg" = Jpg @@ -71,9 +68,6 @@ formatFromPath = aux . (map toLower) . fileName aux ".gif" = Gif aux _ = Other -data Resolution = Resolution - { width :: Int - , height :: Int } deriving (Show, Generic, FromJSON) type FileProcessor = FileName -- ^ Input path diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index afc8203..dcf9422 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -20,15 +20,13 @@ DuplicateRecordFields , DeriveGeneric , DeriveAnyClass + , NamedFieldPuns #-} module Resource - ( ResourceTree(..) - , DirProcessor - , ItemProcessor - , ThumbnailProcessor - , buildResourceTree - , cleanupResourceDir + ( DirProcessor, ItemProcessor, ThumbnailProcessor + , GalleryItem, GalleryItemProps, Resolution(..) + , buildGalleryTree, galleryCleanupResourceDir ) where @@ -36,79 +34,152 @@ import Control.Concurrent.ParallelIO.Global (parallel) import Data.Function ((&)) import Data.List ((\\), subsequences, sortBy) import Data.Ord (comparing) -import Data.Maybe (mapMaybe) +import Data.Char (toLower) +import Data.Maybe (mapMaybe, fromMaybe) +import qualified Data.Set as Set + +import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON, genericToJSON, genericToEncoding) +import qualified Data.Aeson as JSON + import Files -import Input (InputTree(..), Sidecar) +import Input (InputTree(..), Sidecar(..)) + + +encodingOptions :: JSON.Options +encodingOptions = JSON.defaultOptions + { JSON.fieldLabelModifier = map toLower + , JSON.constructorTagModifier = map toLower + , JSON.sumEncoding = JSON.defaultTaggedObject + { JSON.tagFieldName = "type" + , JSON.contentsFieldName = "contents" + } + } + + + +type Tag = String +type FileSizeKB = Int + + +data Resolution = Resolution + { width :: Int + , height :: Int + } deriving (Generic, Show, FromJSON) +instance ToJSON Resolution where + toJSON = genericToJSON encodingOptions + toEncoding = genericToEncoding encodingOptions --- | Tree representing the compiled gallery resources. -data ResourceTree = - ItemResource - { sidecar :: Sidecar - , resPath :: Path - , thumbnailPath :: Maybe Path } - | DirResource - { items :: [ResourceTree] - , resPath :: Path - , thumbnailPath :: Maybe Path } - deriving Show + +data GalleryItemProps = + Directory { items :: [GalleryItem] } + | Picture + | Other + deriving (Generic, Show) + +instance ToJSON GalleryItemProps where + toJSON = genericToJSON encodingOptions + toEncoding = genericToEncoding encodingOptions + + +data GalleryItem = GalleryItem + { title :: String + , date :: String -- TODO: checked ISO8601 date + , description :: String + , tags :: [Tag] + , path :: Path + , thumbnail :: Maybe Path + , properties :: GalleryItemProps + } deriving (Generic, Show) + +instance ToJSON GalleryItem where + toJSON = genericToJSON encodingOptions + toEncoding = genericToEncoding encodingOptions type DirProcessor = Path -> IO Path type ItemProcessor = Path -> IO Path type ThumbnailProcessor = Path -> IO (Maybe Path) -buildResourceTree :: - DirProcessor -> ItemProcessor -> ThumbnailProcessor -> InputTree - -> IO ResourceTree -buildResourceTree processDir processItem processThumbnail = resNode + +buildGalleryTree :: + DirProcessor -> ItemProcessor -> ThumbnailProcessor + -> String -> InputTree -> IO GalleryItem +buildGalleryTree processDir processItem processThumbnail galleryName inputTree = + mkGalleryItem inputTree >>= return . named galleryName where - resNode (InputFile path sidecar) = + named :: String -> GalleryItem -> GalleryItem + named name item = item { title = name } + + mkGalleryItem :: InputTree -> IO GalleryItem + mkGalleryItem InputFile{path, sidecar} = do processedItem <- processItem path processedThumbnail <- processThumbnail path - return ItemResource - { sidecar = sidecar - , resPath = processedItem - , thumbnailPath = processedThumbnail } - - resNode (InputDir path thumbnailPath items) = + return GalleryItem + { title = optMeta title $ fileName path + , date = optMeta date "" -- TODO: check and normalise dates + , description = optMeta description "" + , tags = optMeta tags [] + , path = processedItem + , thumbnail = processedThumbnail + , properties = Other } -- TODO + where + optMeta :: (Sidecar -> Maybe a) -> a -> a + optMeta get fallback = fromMaybe fallback $ get sidecar + + mkGalleryItem InputDir{path, dirThumbnailPath, items} = do processedDir <- processDir path - processedThumbnail <- maybeThumbnail thumbnailPath - dirItems <- parallel $ map resNode items - return DirResource - { items = dirItems - , resPath = processedDir - , thumbnailPath = processedThumbnail } - - maybeThumbnail :: Maybe Path -> IO (Maybe Path) - maybeThumbnail Nothing = return Nothing - maybeThumbnail (Just path) = processThumbnail path - - -flattenResourceTree :: ResourceTree -> [ResourceTree] -flattenResourceTree item@ItemResource{} = [item] -flattenResourceTree dir@(DirResource items _ _) = - dir:(concatMap flattenResourceTree items) - -outputDiff :: ResourceTree -> FSNode -> [Path] -outputDiff resources ref = - (fsPaths ref) \\ (resPaths $ flattenResourceTree resources) + processedThumbnail <- maybeThumbnail dirThumbnailPath + processedItems <- parallel $ map mkGalleryItem items + return GalleryItem + { title = fileName path + -- 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 + , path = processedDir + , thumbnail = processedThumbnail + , properties = Directory processedItems } + where + maybeThumbnail :: Maybe Path -> IO (Maybe Path) + maybeThumbnail Nothing = return Nothing + maybeThumbnail (Just path) = processThumbnail path + + aggregateChildTags :: [GalleryItem] -> [Tag] + aggregateChildTags = unique . concatMap (\item -> tags (item::GalleryItem)) + + unique :: Ord a => [a] -> [a] + unique = Set.toList . Set.fromList + + +flattenGalleryTree :: GalleryItem -> [GalleryItem] +flattenGalleryTree dir@(GalleryItem _ _ _ _ _ _ (Directory items)) = + dir : concatMap flattenGalleryTree items +flattenGalleryTree simple = [simple] + + +galleryOutputDiff :: GalleryItem -> FSNode -> [Path] +galleryOutputDiff resources ref = + (fsPaths ref) \\ (resPaths $ flattenGalleryTree resources) where - resPaths :: [ResourceTree] -> [Path] - resPaths resList = map resPath resList ++ thumbnailPaths resList + resPaths :: [GalleryItem] -> [Path] + resPaths resList = map (path::(GalleryItem->Path)) resList ++ thumbnailPaths resList - thumbnailPaths :: [ResourceTree] -> [Path] - thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnailPath) + thumbnailPaths :: [GalleryItem] -> [Path] + thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnail) fsPaths :: FSNode -> [Path] fsPaths = map nodePath . tail . flattenDir -cleanupResourceDir :: ResourceTree -> FileName -> IO () -cleanupResourceDir resourceTree outputDir = + +galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () +galleryCleanupResourceDir resourceTree outputDir = readDirectory outputDir - >>= return . outputDiff resourceTree . root + >>= return . galleryOutputDiff resourceTree . root >>= return . sortBy (flip $ comparing pathLength) -- nested files before dirs >>= return . map (localPath . (/>) outputDir) >>= mapM_ remove -- cgit v1.2.3