From ab2f076c5bf546f8aca9910b2b61a1b5a67361bc Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 5 Jan 2020 18:39:47 +0100 Subject: compiler: distinguish item and resource paths GitHub: closes #13 --- compiler/src/Compiler.hs | 5 ++- compiler/src/Files.hs | 2 +- compiler/src/Processors.hs | 84 ++++++++++++++++++++-------------------------- compiler/src/Resource.hs | 80 ++++++++++++++++++++++++++----------------- 4 files changed, 89 insertions(+), 82 deletions(-) (limited to 'compiler/src') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index b9f52e5..d0ec003 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -43,7 +43,7 @@ import Files , ensureParentDir , isOutdated ) import Processors - ( dirFileProcessor, itemFileProcessor, thumbnailFileProcessor + ( itemFileProcessor, thumbnailFileProcessor , skipCached, withCached ) @@ -111,7 +111,7 @@ compileGallery inputDirPath outputDirPath rebuildAll = let itemProc = itemProcessor (pictureMaxResolution config) cache let thumbnailProc = thumbnailProcessor (thumbnailMaxResolution config) cache - let galleryBuilder = buildGalleryTree dirProcessor itemProc thumbnailProc (implicitDirectoryTag config) + let galleryBuilder = buildGalleryTree itemProc thumbnailProc (implicitDirectoryTag config) resources <- galleryBuilder (galleryName config) inputTree galleryCleanupResourceDir resources outputDirPath @@ -123,7 +123,6 @@ compileGallery inputDirPath outputDirPath rebuildAll = outputIndex = outputDirPath indexFile outputViewerConf = outputDirPath viewerConfFile - dirProcessor = dirFileProcessor inputDirPath outputDirPath itemsDir itemProcessor maxRes cache = itemFileProcessor maxRes cache inputDirPath outputDirPath itemsDir thumbnailProcessor thumbRes cache = diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs index 51e97e6..41fc5a8 100644 --- a/compiler/src/Files.hs +++ b/compiler/src/Files.hs @@ -17,7 +17,7 @@ -- along with this program. If not, see . module Files - ( FileName, LocalPath, WebPath, Path + ( FileName, LocalPath, WebPath, Path(..) , (), (), (<.>) , fileName, subPaths, pathLength , localPath, webPath diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index e10dc21..159a425 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -18,14 +18,13 @@ module Processors ( Resolution(..) - , DirFileProcessor, dirFileProcessor , ItemFileProcessor, itemFileProcessor , ThumbnailFileProcessor, thumbnailFileProcessor , skipCached, withCached ) where -import Control.Exception (Exception, PatternMatchFail(..), throw, throwIO) +import Control.Exception (Exception, throwIO) import Data.Function ((&)) import Data.Ratio ((%)) import Data.Char (toLower) @@ -38,7 +37,7 @@ import Codec.Picture import Codec.Picture.Extra -- TODO: compare DCT and bilinear (and Lanczos, but it's not implemented) import Resource - ( DirProcessor, ItemProcessor, ThumbnailProcessor + ( ItemProcessor, ThumbnailProcessor , GalleryItemProps(..), Resolution(..) ) import Files @@ -47,22 +46,27 @@ import Files data ProcessingException = ProcessingException FilePath String deriving Show instance Exception ProcessingException -data Format = - Bmp | Jpg | Png | Tiff | Hdr -- static images - | Gif -- TODO: might be animated - | Unknown + +data PictureFileFormat = Bmp | Jpg | Png | Tiff | Hdr | Gif + +-- TODO: handle video, music, text... +data Format = PictureFormat PictureFileFormat | Unknown formatFromPath :: Path -> Format -formatFromPath = maybe Unknown fromExt . fmap (map toLower) . fmap takeExtension . fileName +formatFromPath = + maybe Unknown fromExt + . fmap (map toLower) + . fmap takeExtension + . fileName where fromExt :: String -> Format - fromExt ".bmp" = Bmp - fromExt ".jpg" = Jpg - fromExt ".jpeg" = Jpg - fromExt ".png" = Png - fromExt ".tiff" = Tiff - fromExt ".hdr" = Hdr - fromExt ".gif" = Gif + fromExt ".bmp" = PictureFormat Bmp + fromExt ".jpg" = PictureFormat Jpg + fromExt ".jpeg" = PictureFormat Jpg + fromExt ".png" = PictureFormat Png + fromExt ".tiff" = PictureFormat Tiff + fromExt ".hdr" = PictureFormat Hdr + fromExt ".gif" = PictureFormat Gif fromExt _ = Unknown @@ -76,7 +80,7 @@ copyFileProcessor inputPath outputPath = (putStrLn $ "Copying:\t" ++ outputPath) >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath -resizeStaticImageUpTo :: Format -> Resolution -> FileProcessor +resizeStaticImageUpTo :: PictureFileFormat -> Resolution -> FileProcessor resizeStaticImageUpTo Bmp = resizeStaticGeneric readBitmap saveBmpImage -- TODO: parameterise export quality for jpg resizeStaticImageUpTo Jpg = resizeStaticGeneric readJpeg (saveJpgImage 80) @@ -89,7 +93,6 @@ resizeStaticImageUpTo Gif = resizeStaticGeneric readGif saveGifImage' saveGifImage' outputPath image = saveGifImage outputPath image & either (throwIO . ProcessingException outputPath) id -resizeStaticImageUpTo _ = throw $ PatternMatchFail "Unhandled format" type StaticImageReader = FilePath -> IO (Either String DynamicImage) @@ -143,16 +146,6 @@ withCached processor inputPath outputPath = skip = putStrLn $ "Skipping:\t" ++ outputPath -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 @@ -162,22 +155,22 @@ type ItemFileProcessor = itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = cached processor inPath outPath - >> return (relOutPath, props) + >> return (props relOutPath) where relOutPath = resClass /> inputRes inPath = localPath $ inputBase /> inputRes outPath = localPath $ outputBase /> relOutPath - (processor, props) = formatProcessor maxResolution $ formatFromPath inputRes + (processor, props) = processorFor maxResolution $ formatFromPath inputRes - formatProcessor :: Maybe Resolution -> Format -> (FileProcessor, GalleryItemProps) - formatProcessor Nothing _ = (copyFileProcessor, Other) - formatProcessor (Just maxRes) Bmp = (resizeStaticImageUpTo Bmp maxRes, Picture) - formatProcessor (Just maxRes) Jpg = (resizeStaticImageUpTo Jpg maxRes, Picture) - formatProcessor (Just maxRes) Png = (resizeStaticImageUpTo Png maxRes, Picture) - formatProcessor (Just maxRes) Tiff = (resizeStaticImageUpTo Tiff maxRes, Picture) - formatProcessor (Just maxRes) Hdr = (resizeStaticImageUpTo Hdr maxRes, Picture) - formatProcessor _ Gif = (copyFileProcessor, Other) -- TODO: handle animated gif resizing - formatProcessor _ Unknown = (copyFileProcessor, Other) -- TODO: handle video reencoding and others? + processorFor :: Maybe Resolution -> Format -> (FileProcessor, Path -> GalleryItemProps) + processorFor Nothing _ = + (copyFileProcessor, Other) + processorFor _ (PictureFormat Gif) = + (copyFileProcessor, Picture) -- TODO: handle animated gif resizing + processorFor (Just maxRes) (PictureFormat picFormat) = + (resizeStaticImageUpTo picFormat maxRes, Picture) + processorFor _ Unknown = + (copyFileProcessor, Other) -- TODO: handle video reencoding and others? type ThumbnailFileProcessor = @@ -188,7 +181,7 @@ type ThumbnailFileProcessor = thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = - cached <$> processor (formatFromPath inputRes) + cached <$> processorFor (formatFromPath inputRes) & process where relOutPath = resClass /> inputRes @@ -201,11 +194,8 @@ thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = proc 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 + processorFor :: Format -> Maybe FileProcessor + processorFor (PictureFormat picFormat) = + Just $ resizeStaticImageUpTo picFormat maxRes + processorFor _ = + Nothing diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index 19bd32c..2019418 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -17,7 +17,7 @@ -- along with this program. If not, see . module Resource - ( DirProcessor, ItemProcessor, ThumbnailProcessor + ( ItemProcessor, ThumbnailProcessor , GalleryItem(..), GalleryItemProps(..), Resolution(..) , buildGalleryTree, galleryCleanupResourceDir ) where @@ -27,7 +27,8 @@ import Control.Concurrent.ParallelIO.Global (parallel) import Data.List ((\\), sortBy) import Data.Ord (comparing) import Data.Char (toLower) -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (mapMaybe, fromMaybe, maybeToList) +import Data.Function ((&)) import qualified Data.Set as Set import GHC.Generics (Generic) @@ -63,8 +64,8 @@ instance ToJSON Resolution where data GalleryItemProps = Directory { items :: [GalleryItem] } - | Picture - | Other + | Picture { resource :: Path } + | Other { resource :: Path } deriving (Generic, Show) instance ToJSON GalleryItemProps where @@ -87,53 +88,60 @@ instance ToJSON GalleryItem where toEncoding = genericToEncoding encodingOptions -type DirProcessor = Path -> IO Path -type ItemProcessor = Path -> IO (Path, GalleryItemProps) +type ItemProcessor = Path -> IO GalleryItemProps type ThumbnailProcessor = Path -> IO (Maybe Path) buildGalleryTree :: - DirProcessor -> ItemProcessor -> ThumbnailProcessor + ItemProcessor -> ThumbnailProcessor -> Bool -> String -> InputTree -> IO GalleryItem -buildGalleryTree processDir processItem processThumbnail addDirTag galleryName inputTree = - mkGalleryItem Nothing inputTree >>= return . named galleryName +buildGalleryTree processItem processThumbnail addDirTag galleryName inputTree = + mkGalleryItem (Path []) inputTree >>= return . named galleryName where named :: String -> GalleryItem -> GalleryItem named name item = item { title = name } - mkGalleryItem :: Maybe String -> InputTree -> IO GalleryItem - mkGalleryItem parent InputFile{path, sidecar} = + mkGalleryItem :: Path -> InputTree -> IO GalleryItem + mkGalleryItem parents InputFile{path, sidecar} = do - (processedItemPath, properties) <- processItem path + properties <- processItem path processedThumbnail <- processThumbnail path return GalleryItem - { title = optMeta title $ fromMaybe "" $ fileName path + { title = itemTitle , date = optMeta date "" -- TODO: check and normalise dates , description = optMeta description "" - , tags = (optMeta tags []) ++ implicitParentTag parent - , path = processedItemPath + , tags = (optMeta tags []) ++ implicitParentTag parents + , path = parents Maybe a) -> a -> a optMeta get fallback = fromMaybe fallback $ get sidecar - mkGalleryItem parent InputDir{path, dirThumbnailPath, items} = + mkGalleryItem parents InputDir{path, dirThumbnailPath, items} = do - processedDir <- processDir path processedThumbnail <- maybeThumbnail dirThumbnailPath - processedItems <- parallel $ map (mkGalleryItem $ fileName path) items + processedItems <- parallel $ map (mkGalleryItem itemPath) items return GalleryItem - { title = fromMaybe "" $ fileName path + { title = itemTitle -- TODO: consider using the most recent item's date? what if empty? , date = "" -- TODO: consider allowing metadata sidecars for directories too , description = "" - , tags = (aggregateChildTags processedItems) ++ implicitParentTag parent - , path = processedDir + , tags = (aggregateChildTags processedItems) ++ implicitParentTag parents + , path = itemPath , thumbnail = processedThumbnail , properties = Directory processedItems } where + itemTitle :: String + itemTitle = fromMaybe "" $ fileName path + + itemPath :: Path + itemPath = parents IO (Maybe Path) maybeThumbnail Nothing = return Nothing maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath @@ -144,9 +152,10 @@ buildGalleryTree processDir processItem processThumbnail addDirTag galleryName i unique :: Ord a => [a] -> [a] unique = Set.toList . Set.fromList - implicitParentTag :: Maybe String -> [Tag] - implicitParentTag Nothing = [] - implicitParentTag (Just parent) = if addDirTag then [parent] else [] + implicitParentTag :: Path -> [Tag] + implicitParentTag parents + | addDirTag = maybeToList $ fileName parents + | otherwise = [] flattenGalleryTree :: GalleryItem -> [GalleryItem] @@ -157,16 +166,25 @@ flattenGalleryTree simple = [simple] galleryOutputDiff :: GalleryItem -> FSNode -> [Path] galleryOutputDiff resources ref = - (fsPaths ref) \\ (resPaths $ flattenGalleryTree resources) + (filesystemPaths ref) \\ (compiledPaths $ flattenGalleryTree resources) where - resPaths :: [GalleryItem] -> [Path] - resPaths resList = map (path::(GalleryItem->Path)) resList ++ thumbnailPaths resList + filesystemPaths :: FSNode -> [Path] + filesystemPaths = map Files.path . tail . flattenDir - thumbnailPaths :: [GalleryItem] -> [Path] - thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnail) + compiledPaths :: [GalleryItem] -> [Path] + compiledPaths items = + resourcePaths items ++ thumbnailPaths items + & concatMap subPaths - fsPaths :: FSNode -> [Path] - fsPaths = map Files.path . tail . flattenDir + resourcePaths :: [GalleryItem] -> [Path] + resourcePaths = mapMaybe (resourcePath . properties) + + resourcePath :: GalleryItemProps -> Maybe Path + resourcePath Directory{} = Nothing + resourcePath resourceProps = Just $ resource resourceProps + + thumbnailPaths :: [GalleryItem] -> [Path] + thumbnailPaths = mapMaybe thumbnail galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () -- cgit v1.2.3