From eb7a652b2244ffa4dd5ba2440b7879127e7c6078 Mon Sep 17 00:00:00 2001 From: pacien Date: Fri, 27 Dec 2019 10:08:19 +0100 Subject: compiler: implement resource processing but break directory cleanup --- compiler/app/Main.hs | 28 +++++- compiler/package.yaml | 5 +- compiler/src/Compiler.hs | 96 ++++++++++++++++++++ compiler/src/Config.hs | 8 +- compiler/src/Files.hs | 31 +++++-- compiler/src/Gallery.hs | 15 +-- compiler/src/Input.hs | 12 ++- compiler/src/Lib.hs | 94 ------------------- compiler/src/Processors.hs | 221 +++++++++++++++++++++++++++++++++++++++++++++ compiler/src/Resource.hs | 65 ++++++++----- 10 files changed, 432 insertions(+), 143 deletions(-) create mode 100644 compiler/src/Compiler.hs delete mode 100644 compiler/src/Lib.hs create mode 100644 compiler/src/Processors.hs (limited to 'compiler') diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index ac9b441..2511998 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -1,6 +1,30 @@ +-- 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 Main where -import Lib +import Compiler main :: IO () -main = testRun +main = compileGallery "../../example" "../../out" diff --git a/compiler/package.yaml b/compiler/package.yaml index 9266466..85740ab 100644 --- a/compiler/package.yaml +++ b/compiler/package.yaml @@ -16,7 +16,6 @@ description: Please see the README on GitHub at = 4.7 && < 5 -#- text - containers - filepath - directory @@ -24,8 +23,8 @@ dependencies: - yaml #- optparse-applicative #- cmdargs -#- JuicyPixels -#- JuicyPixels-extra +- JuicyPixels +- JuicyPixels-extra library: source-dirs: src diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs new file mode 100644 index 0000000..9767394 --- /dev/null +++ b/compiler/src/Compiler.hs @@ -0,0 +1,96 @@ +-- 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 Compiler + ( compileGallery + ) where + + +import Control.Monad +import Data.Function ((&)) +import Data.Ord (comparing) +import Data.List (sortBy, length) +import System.Directory (createDirectoryIfMissing, removePathForcibly) +import System.FilePath (dropFileName, ()) + +import Data.Aeson (ToJSON) +import qualified Data.Aeson as JSON + +import Config +import Files (FileName, readDirectory, localPath, isHidden, nodeName, filterDir, flattenDir, root, (/>), ensureParentDir) +import Input (decodeYamlFile, readInputTree) +import Resource (ResourceTree, buildResourceTree, outputDiff) +import Gallery (buildGalleryTree) +import Processors + + +itemsDir :: String +itemsDir = "items" + +thumbnailsDir :: String +thumbnailsDir = "thumbnails" + + +compileGallery :: FilePath -> FilePath -> IO () +compileGallery inputDirPath outputDirPath = + do + config <- readConfig (inputDirPath "gallery.yaml") + inputDir <- readDirectory inputDirPath + + let isGalleryFile = \n -> nodeName n == "gallery.yaml" + let galleryTree = filterDir (liftM2 (&&) (not . isGalleryFile) (not . isHidden)) inputDir + + inputTree <- readInputTree galleryTree + + let dirProc = dirFileProcessor inputDirPath outputDirPath itemsDir + let itemProc = itemFileProcessor Nothing skipCached inputDirPath outputDirPath itemsDir + let thumbnailProc = thumbnailFileProcessor (Resolution 150 50) skipCached inputDirPath outputDirPath thumbnailsDir + resourceTree <- buildResourceTree dirProc itemProc thumbnailProc inputTree + + putStrLn "\nRESOURCE TREE" + putStrLn (show resourceTree) + + --cleanup resourceTree outputDirPath + + buildGalleryTree resourceTree + & ensureParentDir JSON.encodeFile (outputDirPath "index.json") + + viewer config + & ensureParentDir JSON.encodeFile (outputDirPath "viewer.json") + + where + -- TODO: delete all files, then only non-empty dirs + cleanup :: ResourceTree -> FileName -> IO () + cleanup resourceTree outputDir = + readDirectory outputDir + >>= return . outputDiff resourceTree . root + >>= return . sortBy (flip $ comparing length) -- nested files before dirs + >>= return . map (localPath . (/>) outputDir) + >>= mapM_ remove + + remove :: FileName -> IO () + remove path = + do + putStrLn $ "Removing: " ++ path + removePathForcibly path diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index 6f04818..f147bdd 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-} - -- ldgallery - A static generator which turns a collection of tagged -- pictures into a searchable web gallery. -- @@ -18,6 +16,11 @@ -- 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 Config ( GalleryConfig(..) @@ -25,6 +28,7 @@ module Config , readConfig ) where + import GHC.Generics (Generic) import Data.Aeson (ToJSON, FromJSON) import qualified Data.Aeson as JSON diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs index 77a8c5b..0392efe 100644 --- a/compiler/src/Files.hs +++ b/compiler/src/Files.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric #-} - -- ldgallery - A static generator which turns a collection of tagged -- pictures into a searchable web gallery. -- @@ -18,12 +16,17 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE + DuplicateRecordFields + , DeriveGeneric +#-} module Files ( FileName, LocalPath, WebPath, Path , (), (), localPath, webPath , FSNode(..), AnchoredFSNode(..) , nodePath, nodeName, isHidden, flattenDir, filterDir, readDirectory + , ensureParentDir ) where @@ -31,7 +34,7 @@ import Control.Monad (filterM, mapM) import Data.Bool (bool) import Data.List (isPrefixOf, length, deleteBy) import Data.Function ((&)) -import System.Directory (doesDirectoryExist, listDirectory) +import System.Directory (doesDirectoryExist, listDirectory, createDirectoryIfMissing) import qualified System.FilePath import qualified System.FilePath.Posix @@ -79,13 +82,17 @@ isHidden node = "." `isPrefixOf` filename && length filename > 1 -- | DFS with intermediate dirs first. flattenDir :: FSNode -> [FSNode] flattenDir file@(File _) = [file] -flattenDir dir@(Dir _ childs) = dir:(concatMap flattenDir childs) +flattenDir dir@(Dir _ items) = dir:(concatMap flattenDir items) -- | Filters a dir tree. The root is always returned. -filterDir :: (FSNode -> Bool) -> FSNode -> FSNode -filterDir _ file@(File _) = file -filterDir cond (Dir path childs) = - filter cond childs & map (filterDir cond) & Dir path +filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode +filterDir cond (AnchoredFSNode anchor root) = + AnchoredFSNode anchor (filterNode root) + where + filterNode :: FSNode -> FSNode + filterNode file@(File _) = file + filterNode (Dir path items) = + filter cond items & map filterNode & Dir path readDirectory :: LocalPath -> IO AnchoredFSNode readDirectory root = mkNode [] >>= return . AnchoredFSNode root @@ -103,3 +110,11 @@ readDirectory root = mkNode [] >>= return . AnchoredFSNode root (listDirectory $ localPath (root /> path)) >>= mapM (mkNode . ((>= return . Dir path + + +ensureParentDir :: (FileName -> a -> IO b) -> FileName -> a -> IO b +ensureParentDir writer filePath a = + createDirectoryIfMissing True parentDir + >> writer filePath a + where + parentDir = System.FilePath.dropFileName filePath diff --git a/compiler/src/Gallery.hs b/compiler/src/Gallery.hs index ce52523..f12eddb 100644 --- a/compiler/src/Gallery.hs +++ b/compiler/src/Gallery.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-} - -- ldgallery - A static generator which turns a collection of tagged -- pictures into a searchable web gallery. -- @@ -18,6 +16,11 @@ -- 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(..), buildGalleryTree @@ -94,20 +97,20 @@ instance ToJSON GalleryItem where buildGalleryTree :: ResourceTree -> GalleryItem -buildGalleryTree (ItemResource sidecar path@(filename:_) thumbnailPath) = +buildGalleryTree (ItemResource sidecar path@(filename:_) thumbnail) = GalleryItem { title = optMeta title filename , date = optMeta date "" -- TODO: check and normalise dates , description = optMeta description "" , tags = optMeta tags [] , path = webPath path - , thumbnail = Just $ webPath thumbnailPath + , thumbnail = fmap webPath thumbnail , properties = Unknown } -- TODO where optMeta :: (Sidecar -> Maybe a) -> a -> a optMeta get fallback = fromMaybe fallback $ get sidecar -buildGalleryTree (DirResource dirItems path@(dirname:_) thumbnailPath) = +buildGalleryTree (DirResource dirItems path@(dirname:_) thumbnail) = map buildGalleryTree dirItems & \items -> GalleryItem { title = dirname @@ -117,7 +120,7 @@ buildGalleryTree (DirResource dirItems path@(dirname:_) thumbnailPath) = , description = "" , tags = aggregateChildTags items , path = webPath path - , thumbnail = fmap webPath thumbnailPath + , thumbnail = fmap webPath thumbnail , properties = Directory items } where aggregateChildTags :: [GalleryItem] -> [Tag] diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 681f169..64c1933 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-} - -- ldgallery - A static generator which turns a collection of tagged -- pictures into a searchable web gallery. -- @@ -18,6 +16,11 @@ -- 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 Input ( decodeYamlFile @@ -55,7 +58,7 @@ data InputTree = , sidecar :: Sidecar } | InputDir { path :: Path - , thumbnailPath :: Maybe Path + , dirThumbnailPath :: Maybe Path , items :: [InputTree] } deriving Show @@ -68,8 +71,7 @@ data Sidecar = Sidecar readInputTree :: AnchoredFSNode -> IO InputTree -readInputTree (AnchoredFSNode anchor root@Dir{}) = - filterDir (not . isHidden) root & mkDirNode +readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) mkInputNode (File path@(filename:pathto)) | ".yaml" `isExtensionOf` filename = diff --git a/compiler/src/Lib.hs b/compiler/src/Lib.hs deleted file mode 100644 index b2bbe15..0000000 --- a/compiler/src/Lib.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-} - --- 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 . - - -module Lib - ( testRun - ) where - - -import Data.Function ((&)) -import Data.Ord (comparing) -import Data.List (sortBy, length) -import System.Directory (createDirectoryIfMissing, removePathForcibly) -import System.FilePath (dropFileName, ()) - -import Data.Aeson (ToJSON) -import qualified Data.Aeson as JSON - -import Config -import Files (FileName, readDirectory, localPath, flattenDir, root, (/>)) -import Input (decodeYamlFile, readInputTree) -import Resource (ResourceTree, buildResourceTree, outputDiff) -import Gallery (buildGalleryTree) - - -process :: FilePath -> FilePath -> IO () -process inputDirPath outputDirPath = - do - config <- readConfig (inputDirPath "gallery.yaml") - inputDir <- readDirectory inputDirPath - inputTree <- readInputTree inputDir - - let resourceTree = buildResourceTree inputTree - putStrLn "\nRESOURCE TREE" - putStrLn (show resourceTree) - - -- TODO: make buildResourceTree build a resource compilation strategy - -- (need to know the settings) - -- flatten the tree of resources and their strategies - -- filter resources that are already up to date - -- (or recompile everything if the config file has changed!) - -- execute in parallel - - -- TODO: execute (in parallel) the resource compilation strategy list - -- need to find a good library for that - - cleanup resourceTree outputDirPath - - buildGalleryTree resourceTree - & writeJSON (outputDirPath "index.json") - - viewer config - & writeJSON (outputDirPath "viewer.json") - - where - cleanup :: ResourceTree -> FileName -> IO () - cleanup resourceTree outputDir = - readDirectory outputDir - >>= return . outputDiff resourceTree . root - >>= return . sortBy (flip $ comparing length) -- nested files before dirs - >>= return . map (localPath . (/>) outputDir) - >>= mapM_ remove - - remove :: FileName -> IO () - remove path = - do - putStrLn $ "Removing: " ++ path - removePathForcibly path - - writeJSON :: ToJSON a => FileName -> a -> IO () - writeJSON path obj = - createDirectoryIfMissing True (dropFileName path) - >> JSON.encodeFile path obj - - -testRun :: IO () -testRun = process "../../example" "../../out" diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs new file mode 100644 index 0000000..a296215 --- /dev/null +++ b/compiler/src/Processors.hs @@ -0,0 +1,221 @@ +-- 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 + , FlexibleContexts +#-} + +module Processors + ( Resolution(..) + , DirFileProcessor, dirFileProcessor + , ItemFileProcessor, itemFileProcessor + , ThumbnailFileProcessor, thumbnailFileProcessor + , skipCached, withCached + ) where + + +import Control.Exception (throwIO) +import Data.Function ((&)) +import Data.Ratio ((%)) + +import System.Directory hiding (copyFile) +import qualified System.Directory +import System.FilePath + +import Codec.Picture +import Codec.Picture.Extra -- TODO: compare DCT and bilinear (and Lanczos, but it's not implemented) + +import Resource +import Files + + +data Format = + Bmp | Jpg | Png | Tiff | Hdr -- static images + | Gif -- TODO: might be animated + | Other + +formatFromExt :: String -> Format +formatFromExt ".bmp" = Bmp +formatFromExt ".jpg" = Jpg +formatFromExt ".jpeg" = Jpg +formatFromExt ".png" = Png +formatFromExt ".tiff" = Tiff +formatFromExt ".hdr" = Hdr +formatFromExt ".gif" = Gif +formatFromExt _ = Other + +data Resolution = Resolution + { width :: Int + , height :: Int } deriving Show + +type FileProcessor = + FileName -- ^ Input path + -> FileName -- ^ Output path + -> IO () + +copyFileProcessor :: FileProcessor +copyFileProcessor inputPath outputPath = + (putStrLn $ "Copying: " ++ outputPath) + >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath + +eitherIOToIO :: Either String (IO a) -> IO a +eitherIOToIO (Left err) = throwIO $ userError err +eitherIOToIO (Right res) = res + +eitherResToIO :: Either String a -> IO a +eitherResToIO (Left err) = throwIO $ userError err +eitherResToIO (Right res) = return res + +resizeStaticImageUpTo :: Format -> Resolution -> FileProcessor +resizeStaticImageUpTo Bmp = resizeStaticGeneric readBitmap saveBmpImage +-- TODO: parameterise export quality for jpg +resizeStaticImageUpTo Jpg = resizeStaticGeneric readJpeg (saveJpgImage 80) +resizeStaticImageUpTo Png = resizeStaticGeneric readPng savePngImage +resizeStaticImageUpTo Tiff = resizeStaticGeneric readTiff saveTiffImage +resizeStaticImageUpTo Hdr = resizeStaticGeneric readHDR saveRadianceImage +resizeStaticImageUpTo Gif = resizeStaticGeneric readGif ((.) eitherIOToIO . saveGifImage) + + +type StaticImageReader = FilePath -> IO (Either String DynamicImage) +type StaticImageWriter = FilePath -> DynamicImage -> IO () + +resizeStaticGeneric :: StaticImageReader -> StaticImageWriter -> Resolution -> FileProcessor +resizeStaticGeneric reader writer maxRes inputPath outputPath = + (putStrLn $ "Generating: " ++ outputPath) + >> reader inputPath + >>= eitherResToIO + >>= return . (fitDynamicImage maxRes) + >>= ensureParentDir writer outputPath + +fitDynamicImage :: Resolution -> DynamicImage -> DynamicImage +fitDynamicImage (Resolution boxWidth boxHeight) image = + convertRGBA8 image + & scaleBilinear targetWidth targetHeight + & ImageRGBA8 + where + picWidth = dynamicMap imageWidth image + picHeight = dynamicMap imageHeight image + resizeRatio = min (boxWidth % picWidth) (boxHeight % picHeight) + targetWidth = floor $ resizeRatio * (picWidth % 1) + targetHeight = floor $ resizeRatio * (picHeight % 1) + + +type Cache = FileProcessor -> FileProcessor + +skipCached :: Cache +skipCached processor inputPath outputPath = + removePathForcibly outputPath + >> processor inputPath outputPath + +withCached :: Cache +withCached processor inputPath outputPath = + do + isDir <- doesDirectoryExist outputPath + if isDir then removePathForcibly outputPath else noop + + fileExists <- doesFileExist outputPath + if fileExists then + do + needUpdate <- isOutdated inputPath outputPath + if needUpdate then update else skip + else + update + + where + noop = return () + update = processor inputPath outputPath + skip = putStrLn $ "Skipping: " ++ outputPath + + isOutdated :: FilePath -> FilePath -> IO Bool + isOutdated ref target = + do + refTime <- getModificationTime ref + targetTime <- getModificationTime target + return (targetTime < refTime) + + +type DirFileProcessor = + FileName -- ^ Input base path + -> FileName -- ^ Output base path + -> FileName -- ^ Output class (subdir) + -> DirProcessor + +dirFileProcessor :: DirFileProcessor +dirFileProcessor _ _ = (.) return . (/>) + + +type ItemFileProcessor = + FileName -- ^ Input base path + -> FileName -- ^ Output base path + -> FileName -- ^ Output class (subdir) + -> ItemProcessor + +itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor +itemFileProcessor maxRes cached inputBase outputBase resClass inputRes = + cached (processor maxRes (extOf inputRes)) inPath outPath + >> return relOutPath + where + extOf = formatFromExt . takeExtension . head + relOutPath = resClass /> inputRes + inPath = localPath $ inputBase /> inputRes + outPath = localPath $ outputBase /> relOutPath + + processor :: Maybe Resolution -> Format -> FileProcessor + processor Nothing _ = copyFileProcessor + processor (Just maxRes) Bmp = resizeStaticImageUpTo Bmp maxRes + processor (Just maxRes) Jpg = resizeStaticImageUpTo Jpg maxRes + processor (Just maxRes) Png = resizeStaticImageUpTo Png maxRes + processor (Just maxRes) Tiff = resizeStaticImageUpTo Tiff maxRes + processor (Just maxRes) Hdr = resizeStaticImageUpTo Hdr maxRes + processor _ Gif = copyFileProcessor -- TODO: handle animated gif resizing + processor _ Other = copyFileProcessor -- TODO: handle video reencoding and others? + + +type ThumbnailFileProcessor = + FileName -- ^ Input base path + -> FileName -- ^ Output base path + -> FileName -- ^ Output class (subdir) + -> ThumbnailProcessor + +thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor +thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = + cached <$> processor (extOf inputRes) + & process + where + extOf = formatFromExt . takeExtension . head + relOutPath = resClass /> inputRes + inPath = localPath $ inputBase /> inputRes + outPath = localPath $ outputBase /> relOutPath + + process :: Maybe FileProcessor -> IO (Maybe Path) + process Nothing = return Nothing + process (Just processor) = + processor inPath outPath + >> return (Just relOutPath) + + processor :: Format -> Maybe FileProcessor + processor Bmp = Just $ resizeStaticImageUpTo Bmp maxRes + processor Jpg = Just $ resizeStaticImageUpTo Jpg maxRes + processor Png = Just $ resizeStaticImageUpTo Png maxRes + processor Tiff = Just $ resizeStaticImageUpTo Tiff maxRes + processor Hdr = Just $ resizeStaticImageUpTo Hdr maxRes + processor Gif = Just $ resizeStaticImageUpTo Gif maxRes -- static thumbnail from first frame + processor _ = Nothing diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index 60b783e..dc849cd 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-} - -- ldgallery - A static generator which turns a collection of tagged -- pictures into a searchable web gallery. -- @@ -18,9 +16,17 @@ -- 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 Resource ( ResourceTree(..) + , DirProcessor + , ItemProcessor + , ThumbnailProcessor , buildResourceTree , flattenResourceTree , outputDiff @@ -29,8 +35,9 @@ module Resource import Data.Function ((&)) import Data.List ((\\)) +import Data.Maybe (mapMaybe) import Files -import Input +import Input (InputTree(..), Sidecar) -- | Tree representing the compiled gallery resources. @@ -38,33 +45,46 @@ data ResourceTree = ItemResource { sidecar :: Sidecar , resPath :: Path - , itemThumbnailPath :: Path } + , thumbnailPath :: Maybe Path } | DirResource { items :: [ResourceTree] , resPath :: Path - , dirThumbnailPath :: Maybe Path } + , thumbnailPath :: Maybe Path } deriving Show --- TODO: actually generate compilation strategies -buildResourceTree :: InputTree -> ResourceTree -buildResourceTree = resNode +type DirProcessor = Path -> IO Path +type ItemProcessor = Path -> IO Path +type ThumbnailProcessor = Path -> IO (Maybe Path) + +-- TODO: parallelise this! +buildResourceTree :: + DirProcessor -> ItemProcessor -> ThumbnailProcessor -> InputTree + -> IO ResourceTree +buildResourceTree processDir processItem processThumbnail = resNode where resNode (InputFile path sidecar) = - ItemResource - { sidecar = sidecar - , resPath = itemsDir /> path - , itemThumbnailPath = thumbnailsDir /> path } + do + processedItem <- processItem path + processedThumbnail <- processThumbnail path + return ItemResource + { sidecar = sidecar + , resPath = processedItem + , thumbnailPath = processedThumbnail } resNode (InputDir path thumbnailPath items) = - map resNode items - & \dirItems -> DirResource - { items = dirItems - , resPath = itemsDir /> path - , dirThumbnailPath = fmap ((/>) thumbnailsDir) thumbnailPath } + do + processedDir <- processDir path + processedThumbnail <- maybeThumbnail thumbnailPath + dirItems <- mapM resNode items + return DirResource + { items = dirItems + , resPath = processedDir + , thumbnailPath = processedThumbnail } - itemsDir = "items" - thumbnailsDir = "thumbnails" + maybeThumbnail :: Maybe Path -> IO (Maybe Path) + maybeThumbnail Nothing = return Nothing + maybeThumbnail (Just path) = processThumbnail path flattenResourceTree :: ResourceTree -> [ResourceTree] @@ -72,12 +92,11 @@ flattenResourceTree item@ItemResource{} = [item] flattenResourceTree dir@(DirResource items _ _) = dir:(concatMap flattenResourceTree items) - outputDiff :: ResourceTree -> FSNode -> [Path] -outputDiff resources ref = (fsPaths ref) \\ (resPaths resources) +outputDiff resources ref = (fsPaths ref) \\ (resPaths $ flattenResourceTree resources) where - resPaths :: ResourceTree -> [Path] - resPaths = map resPath . flattenResourceTree + resPaths :: [ResourceTree] -> [Path] + resPaths resList = (map resPath resList) ++ (mapMaybe thumbnailPath resList) fsPaths :: FSNode -> [Path] fsPaths = map nodePath . tail . flattenDir -- cgit v1.2.3