From 52abb806a3bde6eb69d64564d971efae2cbfda24 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 15 Jun 2020 04:46:11 +0200 Subject: compiler: reuse derived item properties from last compilation A benchmark on an already bulit gallery with ~600 pictures shows a ~90% speedup: Before: Time (mean ± σ): 2.879 s ± 0.125 s [User: 14.686 s, System: 5.511 s] Range (min … max): 2.774 s … 3.203 s 10 runs After: Time (mean ± σ): 289.5 ms ± 15.1 ms [User: 596.1 ms, System: 359.3 ms] Range (min … max): 272.8 ms … 323.0 ms 10 runs GitHub: closes #97 --- compiler/src/Caching.hs | 52 ++++++++++++++++++-------- compiler/src/Compiler.hs | 51 +++++++++++++++++++++---- compiler/src/FileProcessors.hs | 59 ++++++++++++++++++++++------- compiler/src/Input.hs | 4 +- compiler/src/ItemProcessors.hs | 85 +++++++++++++++++------------------------- compiler/src/Resource.hs | 38 ++++++++++++------- 6 files changed, 185 insertions(+), 104 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Caching.hs b/compiler/src/Caching.hs index b2b1ee1..c2b5a43 100644 --- a/compiler/src/Caching.hs +++ b/compiler/src/Caching.hs @@ -18,39 +18,59 @@ module Caching ( Cache - , skipCache - , withCache + , noCache + , ItemCache + , buildItemCache + , useCached ) where import Control.Monad (when) +import qualified Data.Map.Strict as Map import System.Directory (removePathForcibly, doesDirectoryExist, doesFileExist) import FileProcessors (FileProcessor) +import Resource (GalleryItem(..), flattenGalleryTree) import Files -type Cache = FileProcessor -> FileProcessor +type Cache a = FileProcessor a -> FileProcessor a -skipCache :: Cache -skipCache processor inputPath outputPath = - removePathForcibly outputPath - >> processor inputPath outputPath -withCache :: Cache -withCache processor inputPath outputPath = +noCache :: Cache a +noCache processor itemPath resPath inputFsPath outputFsPath = + removePathForcibly outputFsPath + >> processor itemPath resPath inputFsPath outputFsPath + + +type ItemCache = Path -> Maybe GalleryItem + +buildItemCache :: Maybe GalleryItem -> ItemCache +buildItemCache cachedItems = lookupCache + where + withKey item = (webPath $ Resource.path item, item) + cachedItemList = maybe [] flattenGalleryTree cachedItems + cachedMap = Map.fromList (map withKey cachedItemList) + lookupCache path = Map.lookup (webPath path) cachedMap + +useCached :: ItemCache -> (GalleryItem -> a) -> Cache a +useCached cache propGetter processor itemPath resPath inputFsPath outputFsPath = do - isDir <- doesDirectoryExist outputPath - when isDir $ removePathForcibly outputPath + isDir <- doesDirectoryExist outputFsPath + when isDir $ removePathForcibly outputFsPath - fileExists <- doesFileExist outputPath + fileExists <- doesFileExist outputFsPath if fileExists then do - needUpdate <- isOutdated True inputPath outputPath - if needUpdate then update else skip + needUpdate <- isOutdated True inputFsPath outputFsPath + case (needUpdate, cache itemPath) of + (False, Just props) -> fromCache props + _ -> update else update where - update = processor inputPath outputPath - skip = putStrLn $ "Skipping:\t" ++ outputPath + update = processor itemPath resPath inputFsPath outputFsPath + fromCache props = + putStrLn ("From cache:\t" ++ outputFsPath) + >> return (propGetter props) diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 92e6ed6..1ec55c5 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -24,17 +24,25 @@ module Compiler import GHC.Generics (Generic) import Control.Monad (liftM2, when) +import Data.Bool (bool) import Data.Maybe (fromMaybe) import System.FilePath (()) import qualified System.FilePath.Glob as Glob -import System.Directory (canonicalizePath) +import System.Directory (canonicalizePath, doesFileExist) import Data.Aeson (ToJSON, FromJSON) import qualified Data.Aeson as JSON import Config import Input (InputTree, readInputTree, filterInputTree, sidecar, tags) -import Resource (GalleryItem, buildGalleryTree, galleryCleanupResourceDir) +import Resource + ( GalleryItem + , GalleryItemProps + , Thumbnail + , buildGalleryTree + , galleryCleanupResourceDir + , properties + , thumbnail) import Files ( FileName , FSNode(..) @@ -43,8 +51,8 @@ import Files , nodeName , filterDir , ensureParentDir ) -import ItemProcessors (itemFileProcessor, thumbnailFileProcessor) -import Caching (skipCache, withCache) +import ItemProcessors (ItemProcessor, itemFileProcessor, thumbnailFileProcessor) +import Caching (Cache, noCache, buildItemCache, useCached) defaultGalleryConf :: String @@ -72,6 +80,15 @@ writeJSON outputPath object = putStrLn $ "Generating:\t" ++ outputPath ensureParentDir JSON.encodeFile outputPath object +loadGalleryIndex :: FilePath -> IO (Maybe GalleryIndex) +loadGalleryIndex path = + doesFileExist path >>= bool (return Nothing) decodeIndex + where + decodeIndex = + JSON.eitherDecodeFileStrict path + >>= either (\err -> warn err >> return Nothing) (return . Just) + warn = putStrLn . ("Warning:\tUnable to reuse existing index as cache: " ++) + (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (&&&) = liftM2 (&&) @@ -126,14 +143,17 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir inputTree <- readInputTree sourceTree let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree - let cache = if rebuildAll then skipCache else withCache - let itemProc = itemProcessor config cache - let thumbnailProc = thumbnailProcessor config cache + let galleryIndexPath = outputGalleryIndex outputIndexPath + cachedIndex <- loadCachedIndex galleryIndexPath + let cache = mkCache cachedIndex + + let itemProc = itemProcessor config (cache Resource.properties) + let thumbnailProc = thumbnailProcessor config (cache Resource.thumbnail) let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config) resources <- galleryBuilder curatedInputTree when cleanOutput $ galleryCleanupResourceDir resources outputDirPath - writeJSON (outputGalleryIndex outputIndexPath) $ GalleryIndex (viewerConfig config) resources + writeJSON galleryIndexPath $ GalleryIndex (viewerConfig config) resources where inputGalleryConf :: FilePath -> FilePath @@ -144,10 +164,25 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir outputGalleryIndex "" = outputDirPath defaultIndexFile outputGalleryIndex file = file + loadCachedIndex :: FilePath -> IO (Maybe GalleryIndex) + loadCachedIndex galleryIndexPath = + if rebuildAll + then return Nothing + else loadGalleryIndex galleryIndexPath + + mkCache :: Maybe GalleryIndex -> (GalleryItem -> a) -> Cache a + mkCache refGalleryIndex = + if rebuildAll + then const noCache + else useCached (buildItemCache $ fmap tree refGalleryIndex) + + itemProcessor :: GalleryConfig -> Cache GalleryItemProps -> ItemProcessor GalleryItemProps itemProcessor config cache = itemFileProcessor (pictureMaxResolution config) cache inputDirPath outputDirPath itemsDir + + thumbnailProcessor :: GalleryConfig -> Cache (Maybe Thumbnail) -> ItemProcessor (Maybe Thumbnail) thumbnailProcessor config cache = thumbnailFileProcessor (thumbnailMaxResolution config) cache diff --git a/compiler/src/FileProcessors.hs b/compiler/src/FileProcessors.hs index 8ea04d1..5c4e1c8 100644 --- a/compiler/src/FileProcessors.hs +++ b/compiler/src/FileProcessors.hs @@ -18,12 +18,18 @@ module FileProcessors ( FileProcessor + , transformThenDescribe + , copyResource + , noopProcessor + , FileTransformer , copyFileProcessor , resizePictureUpTo , resourceAt , getImageResolution - , ItemDescriber + , FileDescriber + , getResProps , getPictureProps + , getThumbnailProps ) where @@ -35,24 +41,43 @@ import System.Directory (getModificationTime) import qualified System.Directory import Config (Resolution(..)) -import Resource (Resource(..), GalleryItemProps(..)) +import Resource (Resource(..), GalleryItemProps(..), Thumbnail(..)) import Files data ProcessingException = ProcessingException FilePath String deriving Show instance Exception ProcessingException -type FileProcessor = +type FileProcessor a = + Path -- ^ Item path + -> Path -- ^ Target resource path + -> FilePath -- ^ Filesystem input path + -> FilePath -- ^ Filesystem output path + -> IO a + +transformThenDescribe :: FileTransformer -> FileDescriber a -> FileProcessor a +transformThenDescribe transformer describer _itemPath resPath fsInPath fsOutPath = + transformer fsInPath fsOutPath >> describer resPath fsOutPath + +copyResource :: (Resource -> a) -> FileProcessor a +copyResource resPropConstructor = + transformThenDescribe copyFileProcessor (getResProps resPropConstructor) + +noopProcessor :: FileProcessor (Maybe a) +noopProcessor _ _ _ _ = return Nothing + + +type FileTransformer = FileName -- ^ Input path -> FileName -- ^ Output path -> IO () -copyFileProcessor :: FileProcessor +copyFileProcessor :: FileTransformer copyFileProcessor inputPath outputPath = putStrLn ("Copying:\t" ++ outputPath) >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath -resizePictureUpTo :: Resolution -> FileProcessor +resizePictureUpTo :: Resolution -> FileTransformer resizePictureUpTo maxResolution inputPath outputPath = putStrLn ("Generating:\t" ++ outputPath) >> ensureParentDir (flip resize) outputPath inputPath @@ -68,8 +93,10 @@ resizePictureUpTo maxResolution inputPath outputPath = , output ] -resourceAt :: FilePath -> Path -> IO Resource -resourceAt fsPath resPath = Resource resPath <$> getModificationTime fsPath +type FileDescriber a = + Path -- ^ Target resource path + -> FilePath -- ^ Filesystem path + -> IO a getImageResolution :: FilePath -> IO Resolution getImageResolution fsPath = @@ -85,11 +112,17 @@ getImageResolution fsPath = (Just w, Just h) -> return $ Resolution w h _ -> throwIO $ ProcessingException fsPath "Unable to read image resolution." +resourceAt :: FileDescriber Resource +resourceAt resPath fsPath = Resource resPath <$> getModificationTime fsPath + +getResProps :: (Resource -> a) -> FileDescriber a +getResProps resPropsConstructor resPath fsPath = + resPropsConstructor <$> resourceAt resPath fsPath -type ItemDescriber = - FilePath - -> Resource - -> IO GalleryItemProps +getPictureProps :: FileDescriber GalleryItemProps +getPictureProps resPath fsPath = + Picture <$> resourceAt resPath fsPath <*> getImageResolution fsPath -getPictureProps :: ItemDescriber -getPictureProps fsPath resource = Picture resource <$> getImageResolution fsPath +getThumbnailProps :: FileDescriber (Maybe Thumbnail) +getThumbnailProps resPath fsPath = + Just <$> (Thumbnail <$> resourceAt resPath fsPath <*> getImageResolution fsPath) diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 1316cdd..2480f5b 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -28,7 +28,7 @@ import Control.Exception (Exception, AssertionFailed(..), throw, throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import Data.Bool (bool) import Data.List (find) import Data.Time.Clock (UTCTime) @@ -91,7 +91,7 @@ readSidecarFile :: FilePath -> IO Sidecar readSidecarFile filepath = doesFileExist filepath >>= bool (return Nothing) (decodeYamlFile filepath) - <&> maybe emptySidecar id + <&> fromMaybe emptySidecar readInputTree :: AnchoredFSNode -> IO InputTree diff --git a/compiler/src/ItemProcessors.hs b/compiler/src/ItemProcessors.hs index 209bc2a..f967954 100644 --- a/compiler/src/ItemProcessors.hs +++ b/compiler/src/ItemProcessors.hs @@ -19,17 +19,15 @@ module ItemProcessors ( ItemProcessor , itemFileProcessor - , ThumbnailProcessor , thumbnailFileProcessor ) where -import Data.Function ((&)) import Data.Char (toLower) import System.FilePath (takeExtension) import Config (Resolution(..)) -import Resource (ItemProcessor, ThumbnailProcessor, Thumbnail(..), GalleryItemProps(..)) +import Resource (ItemProcessor, Thumbnail(..), GalleryItemProps(..)) import Caching (Cache) import FileProcessors import Files @@ -75,58 +73,43 @@ formatFromPath = _ -> Unknown -type ItemFileProcessor = - FileName -- ^ Input base path - -> FileName -- ^ Output base path - -> FileName -- ^ Output class (subdir) - -> ItemProcessor +type ItemFileProcessor a = + FilePath -- ^ Filesystem input base path + -> FilePath -- ^ Filesystem output base path + -> FileName -- ^ Output class (subdir) + -> ItemProcessor a -itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor -itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = - cached processor inPath outPath - >> resourceAt outPath relOutPath - >>= descriptor outPath - where - relOutPath = resClass /> inputRes - inPath = localPath $ inputBase /> inputRes - outPath = localPath $ outputBase /> relOutPath - (processor, descriptor) = processorFor (formatFromPath inputRes) maxResolution - - processorFor :: Format -> Maybe Resolution -> (FileProcessor, ItemDescriber) - processorFor PictureFormat (Just maxRes) = (resizePictureUpTo maxRes, getPictureProps) - processorFor PictureFormat Nothing = (copyFileProcessor, getPictureProps) - processorFor PlainTextFormat _ = (copyFileProcessor, const $ return . PlainText) - processorFor PortableDocumentFormat _ = (copyFileProcessor, const $ return . PDF) - processorFor VideoFormat _ = (copyFileProcessor, const $ return . Video) - processorFor AudioFormat _ = (copyFileProcessor, const $ return . Audio) - -- TODO: handle video reencoding and others? - processorFor Unknown _ = (copyFileProcessor, const $ return . Other) +callFileProcessor :: (Path -> FileProcessor a) -> Cache a -> ItemFileProcessor a +callFileProcessor processorProvider withCache inputBase outputBase resClass itemPath resPath = + withCache (processorProvider resPath) + itemPath + (resClass /> resPath) + (localPath $ inputBase /> resPath) + (localPath $ outputBase /> (resClass /> resPath)) -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 <$> processorFor (formatFromPath inputRes) - & process +itemFileProcessor :: Maybe Resolution -> Cache GalleryItemProps -> ItemFileProcessor GalleryItemProps +itemFileProcessor maxResolution = + callFileProcessor (flip processorFor maxResolution . formatFromPath) where - relOutPath = resClass /> inputRes - inPath = localPath $ inputBase /> inputRes - outPath = localPath $ outputBase /> relOutPath + processorFor :: Format -> Maybe Resolution -> FileProcessor GalleryItemProps + processorFor PictureFormat (Just maxRes) = + transformThenDescribe (resizePictureUpTo maxRes) getPictureProps + processorFor PictureFormat Nothing = + transformThenDescribe copyFileProcessor getPictureProps + processorFor PlainTextFormat _ = copyResource PlainText + processorFor PortableDocumentFormat _ = copyResource PDF + processorFor VideoFormat _ = copyResource Video + processorFor AudioFormat _ = copyResource Audio + processorFor Unknown _ = copyResource Other + -- TODO: handle video reencoding and others? - process :: Maybe FileProcessor -> IO (Maybe Thumbnail) - process Nothing = return Nothing - process (Just proc) = - do - proc inPath outPath - resource <- resourceAt outPath relOutPath - resolution <- getImageResolution outPath - return $ Just $ Thumbnail resource resolution - processorFor :: Format -> Maybe FileProcessor - processorFor PictureFormat = Just $ resizePictureUpTo maxRes - processorFor _ = Nothing +thumbnailFileProcessor :: Resolution -> Cache (Maybe Thumbnail) -> ItemFileProcessor (Maybe Thumbnail) +thumbnailFileProcessor maxRes = + callFileProcessor (processorFor . formatFromPath) + where + processorFor :: Format -> FileProcessor (Maybe Thumbnail) + processorFor PictureFormat = transformThenDescribe (resizePictureUpTo maxRes) getThumbnailProps + processorFor _ = noopProcessor diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index fa139e0..6b4b44c 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -17,9 +17,15 @@ -- along with this program. If not, see . module Resource - ( ItemProcessor, ThumbnailProcessor - , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..) - , buildGalleryTree, galleryCleanupResourceDir + ( ItemProcessor + , GalleryItem(..) + , GalleryItemProps(..) + , Resolution(..) + , Resource(..) + , Thumbnail(..) + , buildGalleryTree + , galleryCleanupResourceDir + , flattenGalleryTree ) where @@ -115,12 +121,14 @@ data GalleryItem = GalleryItem } deriving (Generic, Show, ToJSON, FromJSON) -type ItemProcessor = Path -> IO GalleryItemProps -type ThumbnailProcessor = Path -> IO (Maybe Thumbnail) +type ItemProcessor a = + Path -- Item path + -> Path -- Resource Path + -> IO a buildGalleryTree :: - ItemProcessor -> ThumbnailProcessor -> TagsFromDirectoriesConfig + ItemProcessor GalleryItemProps -> ItemProcessor (Maybe Thumbnail) -> TagsFromDirectoriesConfig -> InputTree -> IO GalleryItem buildGalleryTree processItem processThumbnail tagsFromDirsConfig = mkGalleryItem [] @@ -128,29 +136,31 @@ buildGalleryTree processItem processThumbnail tagsFromDirsConfig = mkGalleryItem :: [Tag] -> InputTree -> IO GalleryItem mkGalleryItem inheritedTags InputFile{path, modTime, sidecar} = do - properties <- processItem path - processedThumbnail <- processThumbnail path + let itemPath = "/" /> path + properties <- processItem itemPath path + processedThumbnail <- processThumbnail itemPath path return GalleryItem { title = Input.title sidecar ?? fileName path ?? "" , datetime = Input.datetime sidecar ?? toZonedTime modTime , description = Input.description sidecar ?? "" , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags path) - , path = "/" /> path + , path = itemPath , thumbnail = processedThumbnail , properties = properties } mkGalleryItem inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} = do + let itemPath = "/" /> path let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags processedItems <- parallel $ map (mkGalleryItem dirTags) items - processedThumbnail <- maybeThumbnail dirThumbnailPath + processedThumbnail <- maybeThumbnail itemPath dirThumbnailPath return GalleryItem { title = Input.title sidecar ?? fileName path ?? "" , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems ?? toZonedTime modTime , description = Input.description sidecar ?? "" , tags = unique (aggregateTags processedItems ++ parentDirTags path) - , path = "/" /> path + , path = itemPath , thumbnail = processedThumbnail , properties = Directory processedItems } @@ -170,9 +180,9 @@ buildGalleryTree processItem processThumbnail tagsFromDirsConfig = aggregateTags :: [GalleryItem] -> [Tag] aggregateTags = concatMap (\item -> tags (item::GalleryItem)) - maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail) - maybeThumbnail Nothing = return Nothing - maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath + maybeThumbnail :: Path -> Maybe Path -> IO (Maybe Thumbnail) + maybeThumbnail _ Nothing = return Nothing + maybeThumbnail itemPath (Just thumbnailPath) = processThumbnail itemPath thumbnailPath mostRecentModTime :: [GalleryItem] -> Maybe ZonedTime mostRecentModTime = -- cgit v1.2.3