From 04d5cb917f4288c26a308dfda4ba788d77fda8fd Mon Sep 17 00:00:00 2001 From: pacien Date: Wed, 13 May 2020 00:18:16 +0200 Subject: compiler: add plain text file format support through simple copy --- compiler/src/Processors.hs | 7 +++++-- compiler/src/Resource.hs | 1 + 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 02db325..ca8a74c 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -47,8 +47,8 @@ data ProcessingException = ProcessingException FilePath String deriving Show instance Exception ProcessingException --- TODO: handle video, music, text... -data Format = PictureFormat | Unknown +-- TODO: handle video, music, markdown, pdf... +data Format = PictureFormat | PlainTextFormat | Unknown formatFromPath :: Path -> Format formatFromPath = @@ -66,6 +66,8 @@ formatFromPath = ".tiff" -> PictureFormat ".hdr" -> PictureFormat ".gif" -> PictureFormat + ".txt" -> PlainTextFormat + ".md" -> PlainTextFormat -- TODO: handle markdown separately _ -> Unknown @@ -170,6 +172,7 @@ itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = processorFor :: Format -> Maybe Resolution -> (FileProcessor, ItemDescriber) processorFor PictureFormat (Just maxRes) = (resizePictureUpTo maxRes, getPictureProps) processorFor PictureFormat Nothing = (copyFileProcessor, getPictureProps) + processorFor PlainTextFormat _ = (copyFileProcessor, const $ return . PlainText) -- TODO: handle video reencoding and others? processorFor Unknown _ = (copyFileProcessor, const $ return . Other) diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index e134468..5c175f1 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -75,6 +75,7 @@ data GalleryItemProps = | Picture { resource :: Resource , resolution :: Resolution } + | PlainText { resource :: Resource } | Other { resource :: Resource } deriving (Generic, Show) -- cgit v1.2.3 From e9e46a3b3392ab435f7414729592b2b5af4071b6 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 18 May 2020 20:05:14 +0200 Subject: compiler: add pdf resource type --- compiler/src/Processors.hs | 6 ++++-- compiler/src/Resource.hs | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index ca8a74c..2988f83 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -47,8 +47,8 @@ data ProcessingException = ProcessingException FilePath String deriving Show instance Exception ProcessingException --- TODO: handle video, music, markdown, pdf... -data Format = PictureFormat | PlainTextFormat | Unknown +-- TODO: handle video, music, markdown... +data Format = PictureFormat | PlainTextFormat | PortableDocumentFormat | Unknown formatFromPath :: Path -> Format formatFromPath = @@ -68,6 +68,7 @@ formatFromPath = ".gif" -> PictureFormat ".txt" -> PlainTextFormat ".md" -> PlainTextFormat -- TODO: handle markdown separately + ".pdf" -> PortableDocumentFormat _ -> Unknown @@ -173,6 +174,7 @@ itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = processorFor PictureFormat (Just maxRes) = (resizePictureUpTo maxRes, getPictureProps) processorFor PictureFormat Nothing = (copyFileProcessor, getPictureProps) processorFor PlainTextFormat _ = (copyFileProcessor, const $ return . PlainText) + processorFor PortableDocumentFormat _ = (copyFileProcessor, const $ return . PDF) -- TODO: handle video reencoding and others? processorFor Unknown _ = (copyFileProcessor, const $ return . Other) diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index 5c175f1..129a817 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -76,6 +76,7 @@ data GalleryItemProps = { resource :: Resource , resolution :: Resolution } | PlainText { resource :: Resource } + | PDF { resource :: Resource } | Other { resource :: Resource } deriving (Generic, Show) -- cgit v1.2.3 From 516ee7c5599f2c90a636fd9301806bef67830046 Mon Sep 17 00:00:00 2001 From: pacien Date: Tue, 19 May 2020 21:06:16 +0200 Subject: compiler: add audio and video extensions --- compiler/src/Processors.hs | 24 ++++++++++++++++++++++-- compiler/src/Resource.hs | 2 ++ 2 files changed, 24 insertions(+), 2 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 2988f83..0efbf6d 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -47,8 +47,13 @@ data ProcessingException = ProcessingException FilePath String deriving Show instance Exception ProcessingException --- TODO: handle video, music, markdown... -data Format = PictureFormat | PlainTextFormat | PortableDocumentFormat | Unknown +data Format = + PictureFormat + | PlainTextFormat + | PortableDocumentFormat + | VideoFormat + | AudioFormat + | Unknown formatFromPath :: Path -> Format formatFromPath = @@ -69,6 +74,19 @@ formatFromPath = ".txt" -> PlainTextFormat ".md" -> PlainTextFormat -- TODO: handle markdown separately ".pdf" -> PortableDocumentFormat + ".wav" -> AudioFormat + ".oga" -> AudioFormat + ".ogg" -> AudioFormat + ".spx" -> AudioFormat + ".opus" -> AudioFormat + ".flac" -> AudioFormat + ".m4a" -> AudioFormat + ".mp3" -> AudioFormat + ".ogv" -> VideoFormat + ".ogx" -> VideoFormat + ".webm" -> VideoFormat + ".mkv" -> VideoFormat + ".mp4" -> VideoFormat _ -> Unknown @@ -175,6 +193,8 @@ itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = 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) diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index 129a817..c08677d 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -77,6 +77,8 @@ data GalleryItemProps = , resolution :: Resolution } | PlainText { resource :: Resource } | PDF { resource :: Resource } + | Video { resource :: Resource } + | Audio { resource :: Resource } | Other { resource :: Resource } deriving (Generic, Show) -- cgit v1.2.3 From 00c6216259d8a7b131307953ba5000d2b5dc564b Mon Sep 17 00:00:00 2001 From: pacien Date: Sat, 13 Jun 2020 00:06:18 +0200 Subject: compiler: trivial code simplifications Following HLint's advice. --- compiler/src/Compiler.hs | 18 +++++++++--------- compiler/src/Config.hs | 4 ++-- compiler/src/Files.hs | 15 ++++++++------- compiler/src/Input.hs | 13 +++++++------ compiler/src/Processors.hs | 15 +++++---------- compiler/src/Resource.hs | 16 ++++++++-------- 6 files changed, 39 insertions(+), 42 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 749872d..2bb27f9 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -81,16 +81,16 @@ writeJSON outputPath object = (|||) = liftM2 (||) anyPattern :: [String] -> String -> Bool -anyPattern patterns string = any (flip Glob.match string) (map Glob.compile patterns) +anyPattern patterns string = any (flip Glob.match string . Glob.compile) patterns galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool galleryDirFilter config excludedCanonicalDirs = (not . isHidden) &&& (not . isExcludedDir) - &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| - (matchesFile $ anyPattern $ includedFiles config)) - &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) ||| - (matchesFile $ anyPattern $ excludedFiles config))) + &&& (matchesDir (anyPattern $ includedDirectories config) ||| + matchesFile (anyPattern $ includedFiles config)) + &&& (not . (matchesDir (anyPattern $ excludedDirectories config) ||| + matchesFile (anyPattern $ excludedFiles config))) where matchesDir :: (FileName -> Bool) -> FSNode -> Bool @@ -102,17 +102,17 @@ galleryDirFilter config excludedCanonicalDirs = matchesFile _ Dir{} = False isExcludedDir :: FSNode -> Bool - isExcludedDir Dir{canonicalPath} = any (canonicalPath ==) excludedCanonicalDirs + isExcludedDir Dir{canonicalPath} = canonicalPath `elem` excludedCanonicalDirs isExcludedDir File{} = False inputTreeFilter :: GalleryConfig -> InputTree -> Bool inputTreeFilter GalleryConfig{includedTags, excludedTags} = - (hasTagMatching $ anyPattern includedTags) - &&& (not . (hasTagMatching $ anyPattern excludedTags)) + hasTagMatching (anyPattern includedTags) + &&& (not . hasTagMatching (anyPattern excludedTags)) where hasTagMatching :: (String -> Bool) -> InputTree -> Bool - hasTagMatching cond = (any cond) . (fromMaybe [""] . tags) . sidecar + hasTagMatching cond = any cond . (fromMaybe [""] . tags) . sidecar compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO () diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index 0ae0fa1..3c38a17 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -73,8 +73,8 @@ instance FromJSON GalleryConfig where <*> v .:? "includedTags" .!= ["*"] <*> v .:? "excludedTags" .!= [] <*> v .:? "tagCategories" .!= [] - <*> v .:? "tagsFromDirectories" .!= (TagsFromDirectoriesConfig 0 "") - <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 300) + <*> v .:? "tagsFromDirectories" .!= TagsFromDirectoriesConfig 0 "" + <*> v .:? "thumbnailMaxResolution" .!= Resolution 400 300 <*> v .:? "pictureMaxResolution" readConfig :: FileName -> IO GalleryConfig diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs index c769815..40149e1 100644 --- a/compiler/src/Files.hs +++ b/compiler/src/Files.hs @@ -30,6 +30,7 @@ module Files import Data.List (isPrefixOf, length, subsequences, sortOn) import Data.Function ((&)) +import Data.Functor ((<&>)) import Data.Text (pack) import Data.Aeson (ToJSON) import qualified Data.Aeson as JSON @@ -53,7 +54,7 @@ type LocalPath = String type WebPath = String -- | Reversed path component list -data Path = Path [FileName] deriving Show +newtype Path = Path [FileName] deriving Show instance ToJSON Path where toJSON = JSON.String . pack . webPath @@ -120,7 +121,7 @@ isHidden = hiddenName . nodeName -- | DFS with intermediate dirs first. flattenDir :: FSNode -> [FSNode] flattenDir file@File{} = [file] -flattenDir dir@Dir{items} = dir:(concatMap flattenDir items) +flattenDir dir@Dir{items} = dir:concatMap flattenDir items -- | Filters a dir tree. The root is always returned. filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode @@ -133,7 +134,7 @@ filterDir cond (AnchoredFSNode anchor root) = filter cond items & map filterNode & Dir path canonicalPath readDirectory :: LocalPath -> IO AnchoredFSNode -readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root +readDirectory root = AnchoredFSNode root <$> mkNode (Path []) where mkNode :: Path -> IO FSNode mkNode path = @@ -151,10 +152,10 @@ readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root mkDirNode :: Path -> FilePath -> IO FSNode mkDirNode path canonicalPath = - (listDirectory $ localPath (root /> path)) - >>= mapM (mkNode . ((>= return . sortOn nodeName - >>= return . Dir path canonicalPath + listDirectory (localPath (root /> path)) + >>= mapM (mkNode . (path sortOn nodeName + <&> Dir path canonicalPath copyTo :: FilePath -> AnchoredFSNode -> IO () copyTo target AnchoredFSNode{anchor, root} = copyNode root diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 6ed7471..1316cdd 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -27,6 +27,7 @@ import GHC.Generics (Generic) 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.Bool (bool) import Data.List (find) @@ -90,7 +91,7 @@ readSidecarFile :: FilePath -> IO Sidecar readSidecarFile filepath = doesFileExist filepath >>= bool (return Nothing) (decodeYamlFile filepath) - >>= return . maybe emptySidecar id + <&> maybe emptySidecar id readInputTree :: AnchoredFSNode -> IO InputTree @@ -100,13 +101,13 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) mkInputNode file@File{path} - | (not $ isSidecar file) && (not $ isThumbnail file) = + | not (isSidecar file) && not (isThumbnail file) = do sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt) modTime <- getModificationTime $ localPath (anchor /> path) return $ Just $ InputFile path modTime sidecar mkInputNode File{} = return Nothing - mkInputNode dir@Dir{} = mkDirNode dir >>= return . Just + mkInputNode dir@Dir{} = Just <$> mkDirNode dir mkDirNode :: FSNode -> IO InputTree mkDirNode File{} = throw $ AssertionFailed "Input directory is a file" @@ -121,17 +122,17 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root isSidecar Dir{} = False isSidecar File{path} = fileName path - & (maybe False $ isExtensionOf sidecarExt) + & maybe False (isExtensionOf sidecarExt) isThumbnail :: FSNode -> Bool isThumbnail Dir{} = False isThumbnail File{path} = fileName path & fmap dropExtension - & (maybe False (dirPropFile ==)) + & maybe False (dirPropFile ==) findThumbnail :: [FSNode] -> Maybe Path - findThumbnail = (fmap Files.path) . (find isThumbnail) + findThumbnail = fmap Files.path . find isThumbnail -- | Filters an InputTree. The root is always returned. filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 0efbf6d..73529ee 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -57,10 +57,7 @@ data Format = formatFromPath :: Path -> Format formatFromPath = - maybe Unknown fromExt - . fmap (map toLower) - . fmap takeExtension - . fileName + maybe Unknown ((fromExt . map toLower) . takeExtension) . fileName where fromExt :: String -> Format fromExt ext = case ext of @@ -97,12 +94,12 @@ type FileProcessor = copyFileProcessor :: FileProcessor copyFileProcessor inputPath outputPath = - (putStrLn $ "Copying:\t" ++ outputPath) + putStrLn ("Copying:\t" ++ outputPath) >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath resizePictureUpTo :: Resolution -> FileProcessor resizePictureUpTo maxResolution inputPath outputPath = - (putStrLn $ "Generating:\t" ++ outputPath) + putStrLn ("Generating:\t" ++ outputPath) >> ensureParentDir (flip resize) outputPath inputPath where maxSize :: Resolution -> String @@ -143,7 +140,7 @@ withCached processor inputPath outputPath = resourceAt :: FilePath -> Path -> IO Resource -resourceAt fsPath resPath = getModificationTime fsPath >>= return . Resource resPath +resourceAt fsPath resPath = Resource resPath <$> getModificationTime fsPath getImageResolution :: FilePath -> IO Resolution getImageResolution fsPath = @@ -160,9 +157,7 @@ getImageResolution fsPath = _ -> throwIO $ ProcessingException fsPath "Unable to read image resolution." getPictureProps :: ItemDescriber -getPictureProps fsPath resource = - getImageResolution fsPath - >>= return . Picture resource +getPictureProps fsPath resource = Picture resource <$> getImageResolution fsPath type ItemDescriber = diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index c08677d..607c7f6 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -29,6 +29,7 @@ import Data.List.Ordered (minusBy) import Data.Char (toLower) import Data.Maybe (mapMaybe, fromMaybe) import Data.Function ((&)) +import Data.Functor ((<&>)) import qualified Data.Set as Set import Data.Text (pack) import Data.Time.Clock (UTCTime) @@ -119,8 +120,8 @@ type ThumbnailProcessor = Path -> IO (Maybe Thumbnail) buildGalleryTree :: ItemProcessor -> ThumbnailProcessor -> TagsFromDirectoriesConfig -> InputTree -> IO GalleryItem -buildGalleryTree processItem processThumbnail tagsFromDirsConfig inputTree = - mkGalleryItem [] inputTree +buildGalleryTree processItem processThumbnail tagsFromDirsConfig = + mkGalleryItem [] where mkGalleryItem :: [Tag] -> InputTree -> IO GalleryItem mkGalleryItem inheritedTags InputFile{path, modTime, sidecar} = @@ -190,7 +191,7 @@ flattenGalleryTree simple = [simple] galleryOutputDiff :: GalleryItem -> FSNode -> [Path] galleryOutputDiff resources ref = - (filesystemPaths ref) \\ (compiledPaths $ flattenGalleryTree resources) + filesystemPaths ref \\ compiledPaths (flattenGalleryTree resources) where filesystemPaths :: FSNode -> [Path] filesystemPaths = map Files.path . tail . flattenDir @@ -212,8 +213,7 @@ galleryOutputDiff resources ref = thumbnailPaths :: [GalleryItem] -> [Path] thumbnailPaths = - map resourcePath - . map (resource :: (Thumbnail -> Resource)) + map (resourcePath . (resource :: (Thumbnail -> Resource))) . mapMaybe thumbnail (\\) :: [Path] -> [Path] -> [Path] @@ -235,7 +235,7 @@ galleryOutputDiff resources ref = galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () galleryCleanupResourceDir resourceTree outputDir = readDirectory outputDir - >>= return . galleryOutputDiff resourceTree . root - >>= return . sortOn ((0 -) . pathLength) -- nested files before their parent dirs - >>= return . map (localPath . (/>) outputDir) + <&> galleryOutputDiff resourceTree . root + <&> sortOn ((0 -) . pathLength) -- nested files before their parent dirs + <&> map (localPath . (/>) outputDir) >>= mapM_ remove -- cgit v1.2.3 From 34b90f08a21fbe3f1928e16a8ea48f1fc7453e4e Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 15 Jun 2020 05:34:33 +0200 Subject: compiler/Files: simplify subPaths computation Ignoring subsequences that aren't rooted --- compiler/src/Files.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs index 40149e1..1f14e7f 100644 --- a/compiler/src/Files.hs +++ b/compiler/src/Files.hs @@ -28,7 +28,7 @@ module Files ) where -import Data.List (isPrefixOf, length, subsequences, sortOn) +import Data.List (isPrefixOf, length, sortOn) import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Text (pack) @@ -81,7 +81,10 @@ fileName (Path (name:_)) = Just name fileName _ = Nothing subPaths :: Path -> [Path] -subPaths (Path path) = map Path $ subsequences path +subPaths (Path path) = map Path $ subpaths path + where + subpaths [] = [] + subpaths full@(_:r) = full : subpaths r pathLength :: Path -> Int pathLength (Path path) = Data.List.length path -- cgit v1.2.3 From ce2210e6deff1d981186b6d7ddb1176f27e41f49 Mon Sep 17 00:00:00 2001 From: pacien Date: Sat, 13 Jun 2020 03:41:39 +0200 Subject: compiler: make GalleryIndex loadable from JSON --- compiler/src/Compiler.hs | 4 ++-- compiler/src/Config.hs | 2 +- compiler/src/Files.hs | 14 ++++++++++---- compiler/src/Resource.hs | 28 +++++++++++++++------------- 4 files changed, 28 insertions(+), 20 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 2bb27f9..5a7632d 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -29,7 +29,7 @@ import System.FilePath (()) import qualified System.FilePath.Glob as Glob import System.Directory (canonicalizePath) -import Data.Aeson (ToJSON) +import Data.Aeson (ToJSON, FromJSON) import qualified Data.Aeson as JSON import Config @@ -64,7 +64,7 @@ thumbnailsDir = "thumbnails" data GalleryIndex = GalleryIndex { properties :: ViewerConfig , tree :: GalleryItem - } deriving (Generic, Show, ToJSON) + } deriving (Generic, Show, ToJSON, FromJSON) writeJSON :: ToJSON a => FileName -> a -> IO () diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index 3c38a17..afcfb36 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -84,7 +84,7 @@ readConfig = decodeYamlFile data ViewerConfig = ViewerConfig { galleryTitle :: String , tagCategories :: [String] - } deriving (Generic, ToJSON, Show) + } deriving (Generic, ToJSON, FromJSON, Show) viewerConfig :: GalleryConfig -> ViewerConfig viewerConfig GalleryConfig{galleryTitle, tagCategories} = ViewerConfig galleryTitle tagCategories diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs index 1f14e7f..023546b 100644 --- a/compiler/src/Files.hs +++ b/compiler/src/Files.hs @@ -20,7 +20,7 @@ module Files ( FileName, LocalPath, WebPath, Path(..) , (), (), (<.>) , fileName, subPaths, pathLength - , localPath, webPath + , localPath, webPath, fromWebPath , FSNode(..), AnchoredFSNode(..) , nodeName, isHidden, flattenDir, filterDir , readDirectory, copyTo @@ -31,8 +31,8 @@ module Files import Data.List (isPrefixOf, length, sortOn) import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.Text (pack) -import Data.Aeson (ToJSON) +import Data.Text (pack, unpack) +import Data.Aeson (ToJSON, FromJSON) import qualified Data.Aeson as JSON import System.Directory @@ -59,8 +59,11 @@ newtype Path = Path [FileName] deriving Show instance ToJSON Path where toJSON = JSON.String . pack . webPath +instance FromJSON Path where + parseJSON = JSON.withText "Path" (return . fromWebPath . unpack) + instance Eq Path where - (Path left) == (Path right) = left == right + left == right = webPath left == webPath right () :: Path -> Path -> Path (Path l) (Path r) = Path (r ++ l) @@ -95,6 +98,9 @@ localPath (Path path) = System.FilePath.joinPath $ reverse path webPath :: Path -> WebPath webPath (Path path) = System.FilePath.Posix.joinPath $ reverse path +fromWebPath :: WebPath -> Path +fromWebPath = Path . reverse . System.FilePath.Posix.splitDirectories + data FSNode = File diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index 607c7f6..fa139e0 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -31,14 +31,14 @@ import Data.Maybe (mapMaybe, fromMaybe) import Data.Function ((&)) import Data.Functor ((<&>)) import qualified Data.Set as Set -import Data.Text (pack) +import Data.Text (pack, unpack, breakOn) import Data.Time.Clock (UTCTime) import Data.Time.LocalTime (ZonedTime, utc, utcToZonedTime, zonedTimeToUTC) -import Data.Time.Format (formatTime, defaultTimeLocale) +import Data.Time.Format (formatTime, parseTimeM, defaultTimeLocale) import Safe.Foldable (maximumByMay) import GHC.Generics (Generic) -import Data.Aeson (ToJSON, genericToJSON, genericToEncoding) +import Data.Aeson (ToJSON, FromJSON, genericToJSON, genericToEncoding, genericParseJSON) import qualified Data.Aeson as JSON import Files @@ -70,6 +70,13 @@ instance ToJSON Resource where where timestamp = formatTime defaultTimeLocale "%s" modTime +instance FromJSON Resource where + parseJSON = JSON.withText "Resource" (unpackRes . breakOn "?") + where + unpackRes (resPathStr, modTimeStr) = + Resource (fromWebPath $ unpack resPathStr) + <$> parseTimeM True defaultTimeLocale "?%s" (unpack modTimeStr) + data GalleryItemProps = Directory { items :: [GalleryItem] } @@ -87,15 +94,14 @@ instance ToJSON GalleryItemProps where toJSON = genericToJSON encodingOptions toEncoding = genericToEncoding encodingOptions +instance FromJSON GalleryItemProps where + parseJSON = genericParseJSON encodingOptions + data Thumbnail = Thumbnail { resource :: Resource , resolution :: Resolution - } deriving (Generic, Show) - -instance ToJSON Thumbnail where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions + } deriving (Generic, Show, ToJSON, FromJSON) data GalleryItem = GalleryItem @@ -106,11 +112,7 @@ data GalleryItem = GalleryItem , path :: Path , thumbnail :: Maybe Thumbnail , properties :: GalleryItemProps - } deriving (Generic, Show) - -instance ToJSON GalleryItem where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions + } deriving (Generic, Show, ToJSON, FromJSON) type ItemProcessor = Path -> IO GalleryItemProps -- cgit v1.2.3 From 8905383e2d17e2adb4097e1ce2e7f90ab9ceb5f5 Mon Sep 17 00:00:00 2001 From: pacien Date: Sat, 13 Jun 2020 10:58:00 +0200 Subject: compiler: split ItemProcessors, FileProcessors and Caching --- compiler/src/Caching.hs | 56 +++++++++++ compiler/src/Compiler.hs | 7 +- compiler/src/FileProcessors.hs | 95 ++++++++++++++++++ compiler/src/ItemProcessors.hs | 132 ++++++++++++++++++++++++ compiler/src/Processors.hs | 223 ----------------------------------------- 5 files changed, 286 insertions(+), 227 deletions(-) create mode 100644 compiler/src/Caching.hs create mode 100644 compiler/src/FileProcessors.hs create mode 100644 compiler/src/ItemProcessors.hs delete mode 100644 compiler/src/Processors.hs (limited to 'compiler/src') diff --git a/compiler/src/Caching.hs b/compiler/src/Caching.hs new file mode 100644 index 0000000..b2b1ee1 --- /dev/null +++ b/compiler/src/Caching.hs @@ -0,0 +1,56 @@ +-- ldgallery - A static generator which turns a collection of tagged +-- pictures into a searchable web gallery. +-- +-- Copyright (C) 2019-2020 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 Caching + ( Cache + , skipCache + , withCache + ) where + + +import Control.Monad (when) +import System.Directory (removePathForcibly, doesDirectoryExist, doesFileExist) + +import FileProcessors (FileProcessor) +import Files + + +type Cache = FileProcessor -> FileProcessor + +skipCache :: Cache +skipCache processor inputPath outputPath = + removePathForcibly outputPath + >> processor inputPath outputPath + +withCache :: Cache +withCache processor inputPath outputPath = + do + isDir <- doesDirectoryExist outputPath + when isDir $ removePathForcibly outputPath + + fileExists <- doesFileExist outputPath + if fileExists then + do + needUpdate <- isOutdated True inputPath outputPath + if needUpdate then update else skip + else + update + + where + update = processor inputPath outputPath + skip = putStrLn $ "Skipping:\t" ++ outputPath diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 5a7632d..92e6ed6 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -43,9 +43,8 @@ import Files , nodeName , filterDir , ensureParentDir ) -import Processors - ( itemFileProcessor, thumbnailFileProcessor - , skipCached, withCached ) +import ItemProcessors (itemFileProcessor, thumbnailFileProcessor) +import Caching (skipCache, withCache) defaultGalleryConf :: String @@ -127,7 +126,7 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir inputTree <- readInputTree sourceTree let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree - let cache = if rebuildAll then skipCached else withCached + let cache = if rebuildAll then skipCache else withCache let itemProc = itemProcessor config cache let thumbnailProc = thumbnailProcessor config cache let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config) diff --git a/compiler/src/FileProcessors.hs b/compiler/src/FileProcessors.hs new file mode 100644 index 0000000..8ea04d1 --- /dev/null +++ b/compiler/src/FileProcessors.hs @@ -0,0 +1,95 @@ +-- ldgallery - A static generator which turns a collection of tagged +-- pictures into a searchable web gallery. +-- +-- Copyright (C) 2019-2020 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 FileProcessors + ( FileProcessor + , copyFileProcessor + , resizePictureUpTo + , resourceAt + , getImageResolution + , ItemDescriber + , getPictureProps + ) where + + +import Control.Exception (Exception, throwIO) +import System.Process (readProcess, callProcess) +import Text.Read (readMaybe) + +import System.Directory (getModificationTime) +import qualified System.Directory + +import Config (Resolution(..)) +import Resource (Resource(..), GalleryItemProps(..)) +import Files + + +data ProcessingException = ProcessingException FilePath String deriving Show +instance Exception ProcessingException + +type FileProcessor = + FileName -- ^ Input path + -> FileName -- ^ Output path + -> IO () + +copyFileProcessor :: FileProcessor +copyFileProcessor inputPath outputPath = + putStrLn ("Copying:\t" ++ outputPath) + >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath + +resizePictureUpTo :: Resolution -> FileProcessor +resizePictureUpTo maxResolution inputPath outputPath = + putStrLn ("Generating:\t" ++ outputPath) + >> ensureParentDir (flip resize) outputPath inputPath + where + maxSize :: Resolution -> String + maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">" + + resize :: FileName -> FileName -> IO () + resize input output = callProcess "magick" + [ input + , "-auto-orient" + , "-resize", maxSize maxResolution + , output ] + + +resourceAt :: FilePath -> Path -> IO Resource +resourceAt fsPath resPath = Resource resPath <$> getModificationTime fsPath + +getImageResolution :: FilePath -> IO Resolution +getImageResolution fsPath = + readProcess "magick" ["identify", "-format", "%w %h", firstFrame] [] + >>= parseResolution . break (== ' ') + where + firstFrame :: FilePath + firstFrame = fsPath ++ "[0]" + + parseResolution :: (String, String) -> IO Resolution + parseResolution (widthString, heightString) = + case (readMaybe widthString, readMaybe heightString) of + (Just w, Just h) -> return $ Resolution w h + _ -> throwIO $ ProcessingException fsPath "Unable to read image resolution." + + +type ItemDescriber = + FilePath + -> Resource + -> IO GalleryItemProps + +getPictureProps :: ItemDescriber +getPictureProps fsPath resource = Picture resource <$> getImageResolution fsPath diff --git a/compiler/src/ItemProcessors.hs b/compiler/src/ItemProcessors.hs new file mode 100644 index 0000000..209bc2a --- /dev/null +++ b/compiler/src/ItemProcessors.hs @@ -0,0 +1,132 @@ +-- ldgallery - A static generator which turns a collection of tagged +-- pictures into a searchable web gallery. +-- +-- Copyright (C) 2019-2020 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 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 Caching (Cache) +import FileProcessors +import Files + + +data Format = + PictureFormat + | PlainTextFormat + | PortableDocumentFormat + | VideoFormat + | AudioFormat + | Unknown + +formatFromPath :: Path -> Format +formatFromPath = + maybe Unknown ((fromExt . map toLower) . takeExtension) . fileName + where + fromExt :: String -> Format + fromExt ext = case ext of + ".bmp" -> PictureFormat + ".jpg" -> PictureFormat + ".jpeg" -> PictureFormat + ".png" -> PictureFormat + ".tiff" -> PictureFormat + ".hdr" -> PictureFormat + ".gif" -> PictureFormat + ".txt" -> PlainTextFormat + ".md" -> PlainTextFormat -- TODO: handle markdown separately + ".pdf" -> PortableDocumentFormat + ".wav" -> AudioFormat + ".oga" -> AudioFormat + ".ogg" -> AudioFormat + ".spx" -> AudioFormat + ".opus" -> AudioFormat + ".flac" -> AudioFormat + ".m4a" -> AudioFormat + ".mp3" -> AudioFormat + ".ogv" -> VideoFormat + ".ogx" -> VideoFormat + ".webm" -> VideoFormat + ".mkv" -> VideoFormat + ".mp4" -> VideoFormat + _ -> Unknown + + +type ItemFileProcessor = + FileName -- ^ Input base path + -> FileName -- ^ Output base path + -> FileName -- ^ Output class (subdir) + -> ItemProcessor + +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) + + +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 + where + relOutPath = resClass /> inputRes + inPath = localPath $ inputBase /> inputRes + outPath = localPath $ outputBase /> relOutPath + + 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 diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs deleted file mode 100644 index 73529ee..0000000 --- a/compiler/src/Processors.hs +++ /dev/null @@ -1,223 +0,0 @@ --- ldgallery - A static generator which turns a collection of tagged --- pictures into a searchable web gallery. --- --- Copyright (C) 2019-2020 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 Processors - ( Resolution(..) - , ItemFileProcessor, itemFileProcessor - , ThumbnailFileProcessor, thumbnailFileProcessor - , skipCached, withCached - ) where - - -import Control.Exception (Exception, throwIO) -import Control.Monad (when) -import Data.Function ((&)) -import Data.Char (toLower) -import Text.Read (readMaybe) - -import System.Directory hiding (copyFile) -import qualified System.Directory -import System.FilePath - -import System.Process (callProcess, readProcess) - -import Resource - ( ItemProcessor, ThumbnailProcessor - , GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..) ) - -import Files - - -data ProcessingException = ProcessingException FilePath String deriving Show -instance Exception ProcessingException - - -data Format = - PictureFormat - | PlainTextFormat - | PortableDocumentFormat - | VideoFormat - | AudioFormat - | Unknown - -formatFromPath :: Path -> Format -formatFromPath = - maybe Unknown ((fromExt . map toLower) . takeExtension) . fileName - where - fromExt :: String -> Format - fromExt ext = case ext of - ".bmp" -> PictureFormat - ".jpg" -> PictureFormat - ".jpeg" -> PictureFormat - ".png" -> PictureFormat - ".tiff" -> PictureFormat - ".hdr" -> PictureFormat - ".gif" -> PictureFormat - ".txt" -> PlainTextFormat - ".md" -> PlainTextFormat -- TODO: handle markdown separately - ".pdf" -> PortableDocumentFormat - ".wav" -> AudioFormat - ".oga" -> AudioFormat - ".ogg" -> AudioFormat - ".spx" -> AudioFormat - ".opus" -> AudioFormat - ".flac" -> AudioFormat - ".m4a" -> AudioFormat - ".mp3" -> AudioFormat - ".ogv" -> VideoFormat - ".ogx" -> VideoFormat - ".webm" -> VideoFormat - ".mkv" -> VideoFormat - ".mp4" -> VideoFormat - _ -> Unknown - - -type FileProcessor = - FileName -- ^ Input path - -> FileName -- ^ Output path - -> IO () - -copyFileProcessor :: FileProcessor -copyFileProcessor inputPath outputPath = - putStrLn ("Copying:\t" ++ outputPath) - >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath - -resizePictureUpTo :: Resolution -> FileProcessor -resizePictureUpTo maxResolution inputPath outputPath = - putStrLn ("Generating:\t" ++ outputPath) - >> ensureParentDir (flip resize) outputPath inputPath - where - maxSize :: Resolution -> String - maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">" - - resize :: FileName -> FileName -> IO () - resize input output = callProcess "magick" - [ input - , "-auto-orient" - , "-resize", maxSize maxResolution - , output ] - - -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 - when isDir $ removePathForcibly outputPath - - fileExists <- doesFileExist outputPath - if fileExists then - do - needUpdate <- isOutdated True inputPath outputPath - if needUpdate then update else skip - else - update - - where - update = processor inputPath outputPath - skip = putStrLn $ "Skipping:\t" ++ outputPath - - -resourceAt :: FilePath -> Path -> IO Resource -resourceAt fsPath resPath = Resource resPath <$> getModificationTime fsPath - -getImageResolution :: FilePath -> IO Resolution -getImageResolution fsPath = - readProcess "magick" ["identify", "-format", "%w %h", firstFrame] [] - >>= parseResolution . break (== ' ') - where - firstFrame :: FilePath - firstFrame = fsPath ++ "[0]" - - parseResolution :: (String, String) -> IO Resolution - parseResolution (widthString, heightString) = - case (readMaybe widthString, readMaybe heightString) of - (Just w, Just h) -> return $ Resolution w h - _ -> throwIO $ ProcessingException fsPath "Unable to read image resolution." - -getPictureProps :: ItemDescriber -getPictureProps fsPath resource = Picture resource <$> getImageResolution fsPath - - -type ItemDescriber = - FilePath - -> Resource - -> IO GalleryItemProps - - -type ItemFileProcessor = - FileName -- ^ Input base path - -> FileName -- ^ Output base path - -> FileName -- ^ Output class (subdir) - -> ItemProcessor - -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) - - -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 - where - relOutPath = resClass /> inputRes - inPath = localPath $ inputBase /> inputRes - outPath = localPath $ outputBase /> relOutPath - - 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 -- cgit v1.2.3 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