From 987eb81cb5d98262299c7917d752c54907cbbc33 Mon Sep 17 00:00:00 2001 From: pacien Date: Thu, 23 Jan 2020 22:36:21 +0100 Subject: compiler: add directory incl and excl glob settings GitHub: closes #41 --- compiler/src/Compiler.hs | 37 ++++++++++++++++++++----------------- compiler/src/Config.hs | 12 ++++++++---- 2 files changed, 28 insertions(+), 21 deletions(-) (limited to 'compiler') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index a347433..13e9232 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -71,30 +71,35 @@ writeJSON outputPath object = ensureParentDir JSON.encodeFile outputPath object -galleryDirFilter :: ([Glob.Pattern], [Glob.Pattern]) -> FSNode -> Bool -galleryDirFilter (inclusionPatterns, exclusionPatterns) = +galleryDirFilter :: CompilerConfig -> FSNode -> Bool +galleryDirFilter config = (not . isHidden) - &&& (matchName True $ anyPattern inclusionPatterns) - &&& (not . isConfigFile) + &&& (not . matchesFile (== galleryConf)) &&& (not . containsOutputGallery) - &&& (not . (matchName False $ anyPattern exclusionPatterns)) + &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| + (matchesFile $ anyPattern $ includedFiles config)) + &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) ||| + (matchesFile $ anyPattern $ excludedFiles config))) where (&&&) = liftM2 (&&) (|||) = liftM2 (||) - matchName :: Bool -> (FileName -> Bool) -> FSNode -> Bool - matchName matchDir _ Dir{} = matchDir - matchName _ cond file@File{} = maybe False cond $ nodeName file + matchesDir :: (FileName -> Bool) -> FSNode -> Bool + matchesDir cond dir@Dir{} = maybe False cond $ nodeName dir + matchesDir _ File{} = False - anyPattern :: [Glob.Pattern] -> FileName -> Bool - anyPattern patterns filename = any (flip Glob.match filename) patterns + matchesFile :: (FileName -> Bool) -> FSNode -> Bool + matchesFile cond file@File{} = maybe False cond $ nodeName file + matchesFile _ Dir{} = False - isConfigFile = matchName False (== galleryConf) - isGalleryIndex = matchName False (== indexFile) - isViewerIndex = matchName False (== viewerMainFile) + anyPattern :: [String] -> FileName -> Bool + anyPattern patterns filename = any (flip Glob.match filename) (map Glob.compile patterns) + + containsOutputGallery :: FSNode -> Bool containsOutputGallery File{} = False - containsOutputGallery Dir{items} = any (isGalleryIndex ||| isViewerIndex) items + containsOutputGallery Dir{items} = + any (matchesFile (== indexFile) ||| matchesFile (== viewerMainFile)) items compileGallery :: FilePath -> FilePath -> Bool -> IO () @@ -104,9 +109,7 @@ compileGallery inputDirPath outputDirPath rebuildAll = let config = compiler fullConfig inputDir <- readDirectory inputDirPath - let inclusionPatterns = map Glob.compile $ includeFiles config - let exclusionPatterns = map Glob.compile $ excludeFiles config - let sourceFilter = galleryDirFilter (inclusionPatterns, exclusionPatterns) + let sourceFilter = galleryDirFilter config let sourceTree = filterDir sourceFilter inputDir inputTree <- readInputTree sourceTree diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index 53333a5..d670aae 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -34,8 +34,10 @@ import Resource (Resolution(..)) data CompilerConfig = CompilerConfig { galleryName :: String - , includeFiles :: [String] - , excludeFiles :: [String] + , includedDirectories :: [String] + , excludedDirectories :: [String] + , includedFiles :: [String] + , excludedFiles :: [String] , tagsFromDirectories :: Int , thumbnailMaxResolution :: Resolution , pictureMaxResolution :: Maybe Resolution @@ -44,8 +46,10 @@ data CompilerConfig = CompilerConfig instance FromJSON CompilerConfig where parseJSON = withObject "CompilerConfig" $ \v -> CompilerConfig <$> v .:? "galleryName" .!= "Gallery" - <*> v .:? "includeFiles" .!= ["*"] - <*> v .:? "excludeFiles" .!= [] + <*> v .:? "includedDirectories" .!= ["*"] + <*> v .:? "excludedDirectories" .!= [] + <*> v .:? "includedFiles" .!= ["*"] + <*> v .:? "excludedFiles" .!= [] <*> v .:? "tagsFromDirectories" .!= 0 <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 400) <*> v .:? "pictureMaxResolution" -- cgit v1.2.3 From cf91102432b1196b8f3c1fa388b3963948ad49a6 Mon Sep 17 00:00:00 2001 From: pacien Date: Thu, 23 Jan 2020 23:16:07 +0100 Subject: compiler: add jpeg export quality setting GitHub: closes #2 --- compiler/src/Compiler.hs | 16 ++++++---- compiler/src/Config.hs | 2 ++ compiler/src/Processors.hs | 80 ++++++++++++++++++++++++---------------------- 3 files changed, 54 insertions(+), 44 deletions(-) (limited to 'compiler') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 13e9232..aca96bc 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -114,8 +114,8 @@ compileGallery inputDirPath outputDirPath rebuildAll = inputTree <- readInputTree sourceTree let cache = if rebuildAll then skipCached else withCached - let itemProc = itemProcessor (pictureMaxResolution config) cache - let thumbnailProc = thumbnailProcessor (thumbnailMaxResolution config) cache + let itemProc = itemProcessor config cache + let thumbnailProc = thumbnailProcessor config cache let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config) resources <- galleryBuilder (galleryName config) inputTree @@ -128,7 +128,11 @@ compileGallery inputDirPath outputDirPath rebuildAll = outputIndex = outputDirPath indexFile outputViewerConf = outputDirPath viewerConfFile - itemProcessor maxRes cache = - itemFileProcessor maxRes cache inputDirPath outputDirPath itemsDir - thumbnailProcessor thumbRes cache = - thumbnailFileProcessor thumbRes cache inputDirPath outputDirPath thumbnailsDir + itemProcessor config cache = + itemFileProcessor + (pictureMaxResolution config) (jpegExportQuality config) cache + inputDirPath outputDirPath itemsDir + thumbnailProcessor config cache = + thumbnailFileProcessor + (thumbnailMaxResolution config) (jpegExportQuality config) cache + inputDirPath outputDirPath thumbnailsDir diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index d670aae..4446c14 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -41,6 +41,7 @@ data CompilerConfig = CompilerConfig , tagsFromDirectories :: Int , thumbnailMaxResolution :: Resolution , pictureMaxResolution :: Maybe Resolution + , jpegExportQuality :: Int } deriving (Generic, Show) instance FromJSON CompilerConfig where @@ -53,6 +54,7 @@ instance FromJSON CompilerConfig where <*> v .:? "tagsFromDirectories" .!= 0 <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 400) <*> v .:? "pictureMaxResolution" + <*> v .:? "jpegExportQuality" .!= 80 data GalleryConfig = GalleryConfig diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 159a425..1c4a791 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -80,43 +80,47 @@ copyFileProcessor inputPath outputPath = (putStrLn $ "Copying:\t" ++ outputPath) >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath -resizeStaticImageUpTo :: PictureFileFormat -> Resolution -> FileProcessor -resizeStaticImageUpTo Bmp = resizeStaticGeneric readBitmap saveBmpImage --- TODO: parameterise export quality for jpg -resizeStaticImageUpTo Jpg = resizeStaticGeneric readJpeg (saveJpgImage 80) -resizeStaticImageUpTo Png = resizeStaticGeneric readPng savePngImage -resizeStaticImageUpTo Tiff = resizeStaticGeneric readTiff saveTiffImage -resizeStaticImageUpTo Hdr = resizeStaticGeneric readHDR saveRadianceImage -resizeStaticImageUpTo Gif = resizeStaticGeneric readGif saveGifImage' - where - saveGifImage' :: StaticImageWriter - saveGifImage' outputPath image = - saveGifImage outputPath image - & either (throwIO . ProcessingException outputPath) id - +type LossyExportQuality = Int type StaticImageReader = FilePath -> IO (Either String DynamicImage) type StaticImageWriter = FilePath -> DynamicImage -> IO () -resizeStaticGeneric :: StaticImageReader -> StaticImageWriter -> Resolution -> FileProcessor -resizeStaticGeneric reader writer maxRes inputPath outputPath = - (putStrLn $ "Generating:\t" ++ outputPath) - >> reader inputPath - >>= either (throwIO . ProcessingException inputPath) return - >>= return . (fitDynamicImage maxRes) - >>= ensureParentDir writer outputPath - -fitDynamicImage :: Resolution -> DynamicImage -> DynamicImage -fitDynamicImage (Resolution boxWidth boxHeight) image = - convertRGBA8 image - & scaleBilinear targetWidth targetHeight - & ImageRGBA8 +resizeStaticImageUpTo :: Resolution -> LossyExportQuality -> PictureFileFormat -> FileProcessor +resizeStaticImageUpTo maxResolution jpegExportQuality pictureFormat = + resizerFor pictureFormat where - picWidth = dynamicMap imageWidth image - picHeight = dynamicMap imageHeight image - resizeRatio = min (boxWidth % picWidth) (boxHeight % picHeight) - targetWidth = floor $ resizeRatio * (picWidth % 1) - targetHeight = floor $ resizeRatio * (picHeight % 1) + resizerFor :: PictureFileFormat -> FileProcessor + resizerFor Bmp = resizer readBitmap saveBmpImage + resizerFor Jpg = resizer readJpeg (saveJpgImage jpegExportQuality) + resizerFor Png = resizer readPng savePngImage + resizerFor Tiff = resizer readTiff saveTiffImage + resizerFor Hdr = resizer readHDR saveRadianceImage + resizerFor Gif = resizer readGif saveGifImage' + where + saveGifImage' :: StaticImageWriter + saveGifImage' outputPath image = + saveGifImage outputPath image + & either (throwIO . ProcessingException outputPath) id + + resizer :: StaticImageReader -> StaticImageWriter -> FileProcessor + resizer reader writer inputPath outputPath = + (putStrLn $ "Generating:\t" ++ outputPath) + >> reader inputPath + >>= either (throwIO . ProcessingException inputPath) return + >>= return . (fitDynamicImage maxResolution) + >>= ensureParentDir writer outputPath + + fitDynamicImage :: Resolution -> DynamicImage -> DynamicImage + fitDynamicImage (Resolution boxWidth boxHeight) image = + convertRGBA8 image + & scaleBilinear targetWidth targetHeight + & ImageRGBA8 + where + picWidth = dynamicMap imageWidth image + picHeight = dynamicMap imageHeight image + resizeRatio = min (boxWidth % picWidth) (boxHeight % picHeight) + targetWidth = floor $ resizeRatio * (picWidth % 1) + targetHeight = floor $ resizeRatio * (picHeight % 1) type Cache = FileProcessor -> FileProcessor @@ -152,8 +156,8 @@ type ItemFileProcessor = -> FileName -- ^ Output class (subdir) -> ItemProcessor -itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor -itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = +itemFileProcessor :: Maybe Resolution -> LossyExportQuality -> Cache -> ItemFileProcessor +itemFileProcessor maxResolution jpegExportQuality cached inputBase outputBase resClass inputRes = cached processor inPath outPath >> return (props relOutPath) where @@ -168,7 +172,7 @@ itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = processorFor _ (PictureFormat Gif) = (copyFileProcessor, Picture) -- TODO: handle animated gif resizing processorFor (Just maxRes) (PictureFormat picFormat) = - (resizeStaticImageUpTo picFormat maxRes, Picture) + (resizeStaticImageUpTo maxRes jpegExportQuality picFormat, Picture) processorFor _ Unknown = (copyFileProcessor, Other) -- TODO: handle video reencoding and others? @@ -179,8 +183,8 @@ type ThumbnailFileProcessor = -> FileName -- ^ Output class (subdir) -> ThumbnailProcessor -thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor -thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = +thumbnailFileProcessor :: Resolution -> LossyExportQuality -> Cache -> ThumbnailFileProcessor +thumbnailFileProcessor maxRes jpegExportQuality cached inputBase outputBase resClass inputRes = cached <$> processorFor (formatFromPath inputRes) & process where @@ -196,6 +200,6 @@ thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = processorFor :: Format -> Maybe FileProcessor processorFor (PictureFormat picFormat) = - Just $ resizeStaticImageUpTo picFormat maxRes + Just $ resizeStaticImageUpTo maxRes jpegExportQuality picFormat processorFor _ = Nothing -- cgit v1.2.3 From 2a336b297237b546f065f706838f4cefad4c3e7c Mon Sep 17 00:00:00 2001 From: pacien Date: Sat, 25 Jan 2020 13:47:27 +0100 Subject: compiler: add resource timestamp in generated index Add a timestamp to resource paths in the gallery index to invalidate elements in the browser's cache when necessary. Timestamps are added to resource URLs as a dummy numeric parameter. GitHub: closes #40 --- compiler/src/Processors.hs | 16 +++++++++++----- compiler/src/Resource.hs | 40 +++++++++++++++++++++++++++------------- 2 files changed, 38 insertions(+), 18 deletions(-) (limited to 'compiler') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 1c4a791..2abdec5 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -38,7 +38,7 @@ import Codec.Picture.Extra -- TODO: compare DCT and bilinear (and Lanczos, but i import Resource ( ItemProcessor, ThumbnailProcessor - , GalleryItemProps(..), Resolution(..) ) + , GalleryItemProps(..), Resolution(..), Resource(..) ) import Files @@ -150,6 +150,10 @@ withCached processor inputPath outputPath = skip = putStrLn $ "Skipping:\t" ++ outputPath +resourceAt :: FilePath -> Path -> IO Resource +resourceAt fsPath resPath = getModificationTime fsPath >>= return . Resource resPath + + type ItemFileProcessor = FileName -- ^ Input base path -> FileName -- ^ Output base path @@ -159,14 +163,15 @@ type ItemFileProcessor = itemFileProcessor :: Maybe Resolution -> LossyExportQuality -> Cache -> ItemFileProcessor itemFileProcessor maxResolution jpegExportQuality cached inputBase outputBase resClass inputRes = cached processor inPath outPath - >> return (props relOutPath) + >> resourceAt outPath relOutPath + >>= return . props where relOutPath = resClass /> inputRes inPath = localPath $ inputBase /> inputRes outPath = localPath $ outputBase /> relOutPath (processor, props) = processorFor maxResolution $ formatFromPath inputRes - processorFor :: Maybe Resolution -> Format -> (FileProcessor, Path -> GalleryItemProps) + processorFor :: Maybe Resolution -> Format -> (FileProcessor, Resource -> GalleryItemProps) processorFor Nothing _ = (copyFileProcessor, Other) processorFor _ (PictureFormat Gif) = @@ -192,11 +197,12 @@ thumbnailFileProcessor maxRes jpegExportQuality cached inputBase outputBase resC inPath = localPath $ inputBase /> inputRes outPath = localPath $ outputBase /> relOutPath - process :: Maybe FileProcessor -> IO (Maybe Path) + process :: Maybe FileProcessor -> IO (Maybe Resource) process Nothing = return Nothing process (Just proc) = proc inPath outPath - >> return (Just relOutPath) + >> resourceAt outPath relOutPath + >>= return . Just processorFor :: Format -> Maybe FileProcessor processorFor (PictureFormat picFormat) = diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index 56f7a3f..c0ef317 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -18,7 +18,7 @@ module Resource ( ItemProcessor, ThumbnailProcessor - , GalleryItem(..), GalleryItemProps(..), Resolution(..) + , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..) , buildGalleryTree, galleryCleanupResourceDir ) where @@ -30,8 +30,10 @@ import Data.Char (toLower) import Data.Maybe (mapMaybe, fromMaybe, maybeToList) import Data.Function ((&)) import qualified Data.Set as Set +import Data.Text (pack) import Data.Time.Clock (UTCTime) import Data.Time.LocalTime (ZonedTime, utc, utcToZonedTime, zonedTimeToUTC) +import Data.Time.Format (formatTime, defaultTimeLocale) import Safe.Foldable (maximumByMay) import GHC.Generics (Generic) @@ -65,10 +67,22 @@ instance ToJSON Resolution where toEncoding = genericToEncoding encodingOptions +data Resource = Resource + { resourcePath :: Path + , modTime :: UTCTime + } deriving (Generic, Show) + +instance ToJSON Resource where + toJSON Resource{resourcePath, modTime} = + JSON.String $ pack (webPath resourcePath ++ "?" ++ timestamp) + where + timestamp = formatTime defaultTimeLocale "%s" modTime + + data GalleryItemProps = Directory { items :: [GalleryItem] } - | Picture { resource :: Path } - | Other { resource :: Path } + | Picture { resource :: Resource } + | Other { resource :: Resource } deriving (Generic, Show) instance ToJSON GalleryItemProps where @@ -82,7 +96,7 @@ data GalleryItem = GalleryItem , description :: String , tags :: [Tag] , path :: Path - , thumbnail :: Maybe Path + , thumbnail :: Maybe Resource , properties :: GalleryItemProps } deriving (Generic, Show) @@ -92,7 +106,7 @@ instance ToJSON GalleryItem where type ItemProcessor = Path -> IO GalleryItemProps -type ThumbnailProcessor = Path -> IO (Maybe Path) +type ThumbnailProcessor = Path -> IO (Maybe Resource) buildGalleryTree :: @@ -136,7 +150,7 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in subItemsParents :: [String] subItemsParents = (maybeToList $ fileName path) ++ parentTitles - maybeThumbnail :: Maybe Path -> IO (Maybe Path) + maybeThumbnail :: Maybe Path -> IO (Maybe Resource) maybeThumbnail Nothing = return Nothing maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath @@ -175,18 +189,18 @@ galleryOutputDiff resources ref = compiledPaths :: [GalleryItem] -> [Path] compiledPaths items = - resourcePaths items ++ thumbnailPaths items + resPaths items ++ thumbnailPaths items & concatMap subPaths - resourcePaths :: [GalleryItem] -> [Path] - resourcePaths = mapMaybe (resourcePath . properties) + resPaths :: [GalleryItem] -> [Path] + resPaths = mapMaybe (resPath . properties) - resourcePath :: GalleryItemProps -> Maybe Path - resourcePath Directory{} = Nothing - resourcePath resourceProps = Just $ resource resourceProps + resPath :: GalleryItemProps -> Maybe Path + resPath Directory{} = Nothing + resPath resourceProps = Just (resourcePath $ resource resourceProps) thumbnailPaths :: [GalleryItem] -> [Path] - thumbnailPaths = mapMaybe thumbnail + thumbnailPaths = (map resourcePath) . (mapMaybe thumbnail) galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () -- cgit v1.2.3 From c05cbe525ad44273cc1b9b58549af757f549dcb7 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 27 Jan 2020 14:29:47 +0100 Subject: compiler: switch to imagemagick Use ImageMagick to resize images instead of JuicyPixels, using the superior Lanczos resampling and cutting memory usage. This requires ImageMagick to be installed on the host system and the `magick` executable to be present in the PATH. GitHub: closes #49 --- compiler/package.yaml | 3 +- compiler/src/Compiler.hs | 4 +- compiler/src/Config.hs | 2 - compiler/src/Processors.hs | 101 ++++++++++++++------------------------------- 4 files changed, 33 insertions(+), 77 deletions(-) (limited to 'compiler') diff --git a/compiler/package.yaml b/compiler/package.yaml index 043985d..9b96d17 100644 --- a/compiler/package.yaml +++ b/compiler/package.yaml @@ -23,12 +23,11 @@ dependencies: - aeson - yaml - cmdargs -- JuicyPixels -- JuicyPixels-extra - parallel-io - Glob - safe - time +- process default-extensions: - DuplicateRecordFields diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index aca96bc..27598b7 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -130,9 +130,9 @@ compileGallery inputDirPath outputDirPath rebuildAll = itemProcessor config cache = itemFileProcessor - (pictureMaxResolution config) (jpegExportQuality config) cache + (pictureMaxResolution config) cache inputDirPath outputDirPath itemsDir thumbnailProcessor config cache = thumbnailFileProcessor - (thumbnailMaxResolution config) (jpegExportQuality config) cache + (thumbnailMaxResolution config) cache inputDirPath outputDirPath thumbnailsDir diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index 4446c14..d670aae 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -41,7 +41,6 @@ data CompilerConfig = CompilerConfig , tagsFromDirectories :: Int , thumbnailMaxResolution :: Resolution , pictureMaxResolution :: Maybe Resolution - , jpegExportQuality :: Int } deriving (Generic, Show) instance FromJSON CompilerConfig where @@ -54,7 +53,6 @@ instance FromJSON CompilerConfig where <*> v .:? "tagsFromDirectories" .!= 0 <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 400) <*> v .:? "pictureMaxResolution" - <*> v .:? "jpegExportQuality" .!= 80 data GalleryConfig = GalleryConfig diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 2abdec5..4e7c5a7 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -24,17 +24,15 @@ module Processors ) where -import Control.Exception (Exception, throwIO) +import Control.Exception (Exception) import Data.Function ((&)) -import Data.Ratio ((%)) import Data.Char (toLower) import System.Directory hiding (copyFile) import qualified System.Directory import System.FilePath -import Codec.Picture -import Codec.Picture.Extra -- TODO: compare DCT and bilinear (and Lanczos, but it's not implemented) +import System.Process (callProcess) import Resource ( ItemProcessor, ThumbnailProcessor @@ -47,10 +45,8 @@ data ProcessingException = ProcessingException FilePath String deriving Show instance Exception ProcessingException -data PictureFileFormat = Bmp | Jpg | Png | Tiff | Hdr | Gif - -- TODO: handle video, music, text... -data Format = PictureFormat PictureFileFormat | Unknown +data Format = PictureFormat | Unknown formatFromPath :: Path -> Format formatFromPath = @@ -60,14 +56,15 @@ formatFromPath = . fileName where fromExt :: String -> Format - 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 + fromExt ext = case ext of + ".bmp" -> PictureFormat + ".jpg" -> PictureFormat + ".jpeg" -> PictureFormat + ".png" -> PictureFormat + ".tiff" -> PictureFormat + ".hdr" -> PictureFormat + ".gif" -> PictureFormat + _ -> Unknown type FileProcessor = @@ -80,47 +77,16 @@ copyFileProcessor inputPath outputPath = (putStrLn $ "Copying:\t" ++ outputPath) >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath - -type LossyExportQuality = Int -type StaticImageReader = FilePath -> IO (Either String DynamicImage) -type StaticImageWriter = FilePath -> DynamicImage -> IO () - -resizeStaticImageUpTo :: Resolution -> LossyExportQuality -> PictureFileFormat -> FileProcessor -resizeStaticImageUpTo maxResolution jpegExportQuality pictureFormat = - resizerFor pictureFormat +resizePictureUpTo :: Resolution -> FileProcessor +resizePictureUpTo maxResolution inputPath outputPath = + (putStrLn $ "Generating:\t" ++ outputPath) + >> ensureParentDir (flip resize) outputPath inputPath where - resizerFor :: PictureFileFormat -> FileProcessor - resizerFor Bmp = resizer readBitmap saveBmpImage - resizerFor Jpg = resizer readJpeg (saveJpgImage jpegExportQuality) - resizerFor Png = resizer readPng savePngImage - resizerFor Tiff = resizer readTiff saveTiffImage - resizerFor Hdr = resizer readHDR saveRadianceImage - resizerFor Gif = resizer readGif saveGifImage' - where - saveGifImage' :: StaticImageWriter - saveGifImage' outputPath image = - saveGifImage outputPath image - & either (throwIO . ProcessingException outputPath) id - - resizer :: StaticImageReader -> StaticImageWriter -> FileProcessor - resizer reader writer inputPath outputPath = - (putStrLn $ "Generating:\t" ++ outputPath) - >> reader inputPath - >>= either (throwIO . ProcessingException inputPath) return - >>= return . (fitDynamicImage maxResolution) - >>= ensureParentDir writer outputPath - - fitDynamicImage :: Resolution -> DynamicImage -> DynamicImage - fitDynamicImage (Resolution boxWidth boxHeight) image = - convertRGBA8 image - & scaleBilinear targetWidth targetHeight - & ImageRGBA8 - where - picWidth = dynamicMap imageWidth image - picHeight = dynamicMap imageHeight image - resizeRatio = min (boxWidth % picWidth) (boxHeight % picHeight) - targetWidth = floor $ resizeRatio * (picWidth % 1) - targetHeight = floor $ resizeRatio * (picHeight % 1) + maxSize :: Resolution -> String + maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">" + + resize :: FileName -> FileName -> IO () + resize input output = callProcess "magick" [input, "-resize", maxSize maxResolution, output] type Cache = FileProcessor -> FileProcessor @@ -160,8 +126,8 @@ type ItemFileProcessor = -> FileName -- ^ Output class (subdir) -> ItemProcessor -itemFileProcessor :: Maybe Resolution -> LossyExportQuality -> Cache -> ItemFileProcessor -itemFileProcessor maxResolution jpegExportQuality cached inputBase outputBase resClass inputRes = +itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor +itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = cached processor inPath outPath >> resourceAt outPath relOutPath >>= return . props @@ -172,14 +138,9 @@ itemFileProcessor maxResolution jpegExportQuality cached inputBase outputBase re (processor, props) = processorFor maxResolution $ formatFromPath inputRes processorFor :: Maybe Resolution -> Format -> (FileProcessor, Resource -> GalleryItemProps) - processorFor Nothing _ = - (copyFileProcessor, Other) - processorFor _ (PictureFormat Gif) = - (copyFileProcessor, Picture) -- TODO: handle animated gif resizing - processorFor (Just maxRes) (PictureFormat picFormat) = - (resizeStaticImageUpTo maxRes jpegExportQuality picFormat, Picture) - processorFor _ Unknown = - (copyFileProcessor, Other) -- TODO: handle video reencoding and others? + processorFor Nothing _ = (copyFileProcessor, Other) + processorFor (Just maxRes) PictureFormat = (resizePictureUpTo maxRes, Picture) + processorFor _ Unknown = (copyFileProcessor, Other) -- TODO: handle video reencoding and others? type ThumbnailFileProcessor = @@ -188,8 +149,8 @@ type ThumbnailFileProcessor = -> FileName -- ^ Output class (subdir) -> ThumbnailProcessor -thumbnailFileProcessor :: Resolution -> LossyExportQuality -> Cache -> ThumbnailFileProcessor -thumbnailFileProcessor maxRes jpegExportQuality cached inputBase outputBase resClass inputRes = +thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor +thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = cached <$> processorFor (formatFromPath inputRes) & process where @@ -205,7 +166,5 @@ thumbnailFileProcessor maxRes jpegExportQuality cached inputBase outputBase resC >>= return . Just processorFor :: Format -> Maybe FileProcessor - processorFor (PictureFormat picFormat) = - Just $ resizeStaticImageUpTo maxRes jpegExportQuality picFormat - processorFor _ = - Nothing + processorFor PictureFormat = Just $ resizePictureUpTo maxRes + processorFor _ = Nothing -- cgit v1.2.3 From c8692be41903791764de314c099ead7f078eed20 Mon Sep 17 00:00:00 2001 From: pacien Date: Wed, 29 Jan 2020 22:17:13 +0100 Subject: compiler: fix picture item type without resize GitHub: closes #52 --- compiler/src/Processors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 4e7c5a7..f2ade63 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -138,8 +138,8 @@ itemFileProcessor maxResolution cached inputBase outputBase resClass inputRes = (processor, props) = processorFor maxResolution $ formatFromPath inputRes processorFor :: Maybe Resolution -> Format -> (FileProcessor, Resource -> GalleryItemProps) - processorFor Nothing _ = (copyFileProcessor, Other) processorFor (Just maxRes) PictureFormat = (resizePictureUpTo maxRes, Picture) + processorFor Nothing PictureFormat = (copyFileProcessor, Picture) processorFor _ Unknown = (copyFileProcessor, Other) -- TODO: handle video reencoding and others? -- cgit v1.2.3 From 15c806adec22239096a910b92b49fcfb964815bd Mon Sep 17 00:00:00 2001 From: pacien Date: Thu, 30 Jan 2020 17:01:15 +0100 Subject: compiler: add flag for output dir cleanup Making it explicit. GitHub: closes #62 --- compiler/app/Main.hs | 26 +++++++++++++++++++++----- compiler/src/Compiler.hs | 10 +++++++--- 2 files changed, 28 insertions(+), 8 deletions(-) (limited to 'compiler') diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index 1a42abf..4dd6660 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -31,6 +31,7 @@ data Options = Options { inputDir :: String , outputDir :: String , rebuilAll :: Bool + , cleanOutput :: Bool , withViewer :: Bool } deriving (Show, Data, Typeable) @@ -53,6 +54,11 @@ options = Options &= name "rebuild-all" &= explicit &= help "Invalidate cache and recompile everything" + , cleanOutput = False + &= name "c" + &= name "clean-output" + &= explicit + &= help "Remove unnecessary files from the output directory" , withViewer = False &= name "w" &= name "with-viewer" @@ -71,10 +77,23 @@ main :: IO () main = do opts <- cmdArgs options - compileGallery (inputDir opts) (galleryOutputDir "gallery" opts) (rebuilAll opts) - if (withViewer opts) then copyViewer (outputDir opts) else noop + + buildGallery opts + + if (withViewer opts) then + copyViewer (outputDir opts) + else + return () where + buildGallery :: Options -> IO () + buildGallery opts = + compileGallery + (inputDir opts) + (galleryOutputDir "gallery" opts) + (rebuilAll opts) + (cleanOutput opts) + galleryOutputDir :: FilePath -> Options -> FilePath galleryOutputDir gallerySubdir opts = if withViewer opts then outputBase gallerySubdir else outputBase @@ -86,6 +105,3 @@ main = >> getDataFileName "viewer" >>= readDirectory >>= copyTo target - - noop :: IO () - noop = return () diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 27598b7..fc40a76 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -102,8 +102,8 @@ galleryDirFilter config = any (matchesFile (== indexFile) ||| matchesFile (== viewerMainFile)) items -compileGallery :: FilePath -> FilePath -> Bool -> IO () -compileGallery inputDirPath outputDirPath rebuildAll = +compileGallery :: FilePath -> FilePath -> Bool -> Bool -> IO () +compileGallery inputDirPath outputDirPath rebuildAll cleanOutput = do fullConfig <- readConfig inputGalleryConf let config = compiler fullConfig @@ -119,7 +119,11 @@ compileGallery inputDirPath outputDirPath rebuildAll = let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config) resources <- galleryBuilder (galleryName config) inputTree - galleryCleanupResourceDir resources outputDirPath + if cleanOutput then + galleryCleanupResourceDir resources outputDirPath + else + return () + writeJSON outputIndex resources writeJSON outputViewerConf $ viewer fullConfig -- cgit v1.2.3 From 2157b66f3ea43137391939992cac4dc901a4ac4e Mon Sep 17 00:00:00 2001 From: Zero~Informatique Date: Fri, 31 Jan 2020 02:15:26 +0100 Subject: compiler: output viewer config.json Write a file at the root of the viewer directory with some info about the gallery root path and generation date time. --- compiler/app/Main.hs | 30 ++++++++++++++++++++++++------ compiler/data/viewer/readme.md | 2 ++ compiler/src/Compiler.hs | 1 + 3 files changed, 27 insertions(+), 6 deletions(-) create mode 100644 compiler/data/viewer/readme.md (limited to 'compiler') diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index 4dd6660..e26055f 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -18,8 +18,12 @@ module Main where +import GHC.Generics (Generic) import Paths_ldgallery_compiler (version, getDataFileName) import Data.Version (showVersion) +import Data.Int (Int64) +import Data.Aeson (ToJSON) +import Data.Time.Clock.System (getSystemTime, systemSeconds) import System.FilePath (()) import System.Console.CmdArgs @@ -27,6 +31,12 @@ import Compiler import Files (readDirectory, copyTo) +data ViewerConfig = ViewerConfig + { galleryRoot :: String + , generationTimestamp :: Int64 + } deriving (Generic, Show, ToJSON) + + data Options = Options { inputDir :: String , outputDir :: String @@ -77,25 +87,27 @@ main :: IO () main = do opts <- cmdArgs options - buildGallery opts - - if (withViewer opts) then + if (withViewer opts) then do copyViewer (outputDir opts) + writeViewerConfig (outputDir opts "config.json") else return () where + gallerySubdir :: String + gallerySubdir = "gallery/" + buildGallery :: Options -> IO () buildGallery opts = compileGallery (inputDir opts) - (galleryOutputDir "gallery" opts) + (galleryOutputDir opts) (rebuilAll opts) (cleanOutput opts) - galleryOutputDir :: FilePath -> Options -> FilePath - galleryOutputDir gallerySubdir opts = + galleryOutputDir :: Options -> FilePath + galleryOutputDir opts = if withViewer opts then outputBase gallerySubdir else outputBase where outputBase = outputDir opts @@ -105,3 +117,9 @@ main = >> getDataFileName "viewer" >>= readDirectory >>= copyTo target + + writeViewerConfig :: FilePath -> IO () + writeViewerConfig fileName = + getSystemTime + >>= return . ViewerConfig gallerySubdir . systemSeconds + >>= writeJSON fileName diff --git a/compiler/data/viewer/readme.md b/compiler/data/viewer/readme.md new file mode 100644 index 0000000..5786878 --- /dev/null +++ b/compiler/data/viewer/readme.md @@ -0,0 +1,2 @@ +Missing viewer distribution. +Copy the files in "/viewer/dist/*" here, then rebuild the compiler. diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index fc40a76..8819ffc 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -18,6 +18,7 @@ module Compiler ( compileGallery + , writeJSON ) where -- cgit v1.2.3 From 4fde03c7654dcdad11a8c91ba2bcbb2706695e11 Mon Sep 17 00:00:00 2001 From: pacien Date: Thu, 30 Jan 2020 16:03:54 +0100 Subject: compiler: properly exclude out directory Use canonical paths to exclude the output directory if it is located inside the input directory instead of guessing based on special files. GitHub: closes #54 --- compiler/src/Compiler.hs | 20 +++++++++----------- compiler/src/Files.hs | 49 +++++++++++++++++++++++++++++------------------- 2 files changed, 39 insertions(+), 30 deletions(-) (limited to 'compiler') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index 8819ffc..d392f74 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -26,6 +26,7 @@ import Control.Monad (liftM2) import Data.List (any) import System.FilePath (()) import qualified System.FilePath.Glob as Glob +import System.Directory (canonicalizePath) import Data.Aeson (ToJSON) import qualified Data.Aeson as JSON @@ -52,9 +53,6 @@ galleryConf = "gallery.yaml" indexFile :: String indexFile = "index.json" -viewerMainFile :: String -viewerMainFile = "index.html" - viewerConfFile :: String viewerConfFile = "viewer.json" @@ -72,11 +70,11 @@ writeJSON outputPath object = ensureParentDir JSON.encodeFile outputPath object -galleryDirFilter :: CompilerConfig -> FSNode -> Bool -galleryDirFilter config = +galleryDirFilter :: CompilerConfig -> FilePath -> FSNode -> Bool +galleryDirFilter config outputDir = (not . isHidden) + &&& (not . isOutputGallery) &&& (not . matchesFile (== galleryConf)) - &&& (not . containsOutputGallery) &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| (matchesFile $ anyPattern $ includedFiles config)) &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) ||| @@ -97,10 +95,9 @@ galleryDirFilter config = anyPattern :: [String] -> FileName -> Bool anyPattern patterns filename = any (flip Glob.match filename) (map Glob.compile patterns) - containsOutputGallery :: FSNode -> Bool - containsOutputGallery File{} = False - containsOutputGallery Dir{items} = - any (matchesFile (== indexFile) ||| matchesFile (== viewerMainFile)) items + isOutputGallery :: FSNode -> Bool + isOutputGallery Dir{canonicalPath} = canonicalPath == outputDir + isOutputGallery File{} = False compileGallery :: FilePath -> FilePath -> Bool -> Bool -> IO () @@ -110,7 +107,8 @@ compileGallery inputDirPath outputDirPath rebuildAll cleanOutput = let config = compiler fullConfig inputDir <- readDirectory inputDirPath - let sourceFilter = galleryDirFilter config + canonicalOutPath <- canonicalizePath outputDirPath + let sourceFilter = galleryDirFilter config canonicalOutPath let sourceTree = filterDir sourceFilter inputDir inputTree <- readInputTree sourceTree diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs index 41fc5a8..8ea943f 100644 --- a/compiler/src/Files.hs +++ b/compiler/src/Files.hs @@ -29,7 +29,6 @@ module Files import Control.Monad (mapM) -import Data.Bool (bool) import Data.List (isPrefixOf, length, subsequences) import Data.Function ((&)) import Data.Text (pack) @@ -39,6 +38,7 @@ import qualified Data.Aeson as JSON import System.Directory ( doesDirectoryExist , doesPathExist + , canonicalizePath , getModificationTime , listDirectory , createDirectoryIfMissing @@ -94,8 +94,13 @@ webPath (Path path) = System.FilePath.Posix.joinPath $ reverse path data FSNode = - File { path :: Path } - | Dir { path :: Path, items :: [FSNode] } + File + { path :: Path + , canonicalPath :: FilePath } + | Dir + { path :: Path + , canonicalPath :: FilePath + , items :: [FSNode] } deriving Show data AnchoredFSNode = AnchoredFSNode @@ -115,8 +120,8 @@ isHidden = hiddenName . nodeName -- | DFS with intermediate dirs first. flattenDir :: FSNode -> [FSNode] -flattenDir file@(File _) = [file] -flattenDir dir@(Dir _ items) = dir:(concatMap flattenDir items) +flattenDir file@File{} = [file] +flattenDir dir@Dir{items} = dir:(concatMap flattenDir items) -- | Filters a dir tree. The root is always returned. filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode @@ -124,35 +129,41 @@ filterDir cond (AnchoredFSNode anchor root) = AnchoredFSNode anchor (filterNode root) where filterNode :: FSNode -> FSNode - filterNode file@(File _) = file - filterNode (Dir path items) = - filter cond items & map filterNode & Dir path + filterNode file@File{} = file + filterNode Dir{path, canonicalPath, items} = + filter cond items & map filterNode & Dir path canonicalPath readDirectory :: LocalPath -> IO AnchoredFSNode readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root where mkNode :: Path -> IO FSNode mkNode path = - (doesDirectoryExist $ localPath (root /> path)) - >>= bool (mkFileNode path) (mkDirNode path) - - mkFileNode :: Path -> IO FSNode - mkFileNode path = return $ File path - - mkDirNode :: Path -> IO FSNode - mkDirNode path = + do + let relPath = localPath (root /> path) + canonicalPath <- canonicalizePath relPath + isDir <- doesDirectoryExist relPath + if isDir then + mkDirNode path canonicalPath + else + mkFileNode path canonicalPath + + mkFileNode :: Path -> FilePath -> IO FSNode + mkFileNode path canonicalPath = return $ File path canonicalPath + + mkDirNode :: Path -> FilePath -> IO FSNode + mkDirNode path canonicalPath = (listDirectory $ localPath (root /> path)) >>= mapM (mkNode . ((>= return . Dir path + >>= return . Dir path canonicalPath copyTo :: FilePath -> AnchoredFSNode -> IO () copyTo target AnchoredFSNode{anchor, root} = copyNode root where copyNode :: FSNode -> IO () - copyNode (File path) = + copyNode File{path} = copyFile (localPath $ anchor /> path) (localPath $ target /> path) - copyNode (Dir path items) = + copyNode Dir{path, items} = createDirectoryIfMissing True (localPath $ target /> path) >> mapM_ copyNode items -- cgit v1.2.3 From b1cdddcca9b627e8ba1f2870aa5e62043f7b04b3 Mon Sep 17 00:00:00 2001 From: pacien Date: Fri, 31 Jan 2020 18:15:41 +0100 Subject: compiler: auto orient processed images Let ImageMagick re-orient images based on EXIF metadata. Some web browsers still don't support that correctly. GitHub: closes #67 --- compiler/src/Processors.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index f2ade63..df7e632 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -86,7 +86,11 @@ resizePictureUpTo maxResolution inputPath outputPath = maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">" resize :: FileName -> FileName -> IO () - resize input output = callProcess "magick" [input, "-resize", maxSize maxResolution, output] + resize input output = callProcess "magick" + [ input + , "-auto-orient" + , "-resize", maxSize maxResolution + , output ] type Cache = FileProcessor -> FileProcessor -- cgit v1.2.3 From 7dde692101a7e36e0a431aeb864cbf3a0c0e96f8 Mon Sep 17 00:00:00 2001 From: pacien Date: Fri, 31 Jan 2020 19:43:24 +0100 Subject: compiler: add thumbnail size to index --- compiler/src/Processors.hs | 21 +++++++++++++++------ compiler/src/Resource.hs | 28 ++++++++++++++++++++++------ 2 files changed, 37 insertions(+), 12 deletions(-) (limited to 'compiler') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index f2ade63..9ddc6ee 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -27,16 +27,17 @@ module Processors import Control.Exception (Exception) import Data.Function ((&)) import Data.Char (toLower) +import Data.List (break) import System.Directory hiding (copyFile) import qualified System.Directory import System.FilePath -import System.Process (callProcess) +import System.Process (callProcess, readProcess) import Resource ( ItemProcessor, ThumbnailProcessor - , GalleryItemProps(..), Resolution(..), Resource(..) ) + , GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..) ) import Files @@ -119,6 +120,12 @@ withCached processor inputPath outputPath = resourceAt :: FilePath -> Path -> IO Resource resourceAt fsPath resPath = getModificationTime fsPath >>= return . Resource resPath +getImageResolution :: FilePath -> IO Resolution +getImageResolution fsPath = + readProcess "identify" ["-format", "%w %h", fsPath] [] + >>= return . break (== ' ') + >>= return . \(w, h) -> Resolution (read w) (read h) + type ItemFileProcessor = FileName -- ^ Input base path @@ -158,12 +165,14 @@ thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes = inPath = localPath $ inputBase /> inputRes outPath = localPath $ outputBase /> relOutPath - process :: Maybe FileProcessor -> IO (Maybe Resource) + process :: Maybe FileProcessor -> IO (Maybe Thumbnail) process Nothing = return Nothing process (Just proc) = - proc inPath outPath - >> resourceAt outPath relOutPath - >>= return . Just + 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 diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index c0ef317..33f3cf0 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -18,7 +18,7 @@ module Resource ( ItemProcessor, ThumbnailProcessor - , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..) + , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..) , buildGalleryTree, galleryCleanupResourceDir ) where @@ -90,13 +90,23 @@ instance ToJSON GalleryItemProps where toEncoding = genericToEncoding encodingOptions +data Thumbnail = Thumbnail + { resource :: Resource + , resolution :: Resolution + } deriving (Generic, Show) + +instance ToJSON Thumbnail where + toJSON = genericToJSON encodingOptions + toEncoding = genericToEncoding encodingOptions + + data GalleryItem = GalleryItem { title :: String , datetime :: ZonedTime , description :: String , tags :: [Tag] , path :: Path - , thumbnail :: Maybe Resource + , thumbnail :: Maybe Thumbnail , properties :: GalleryItemProps } deriving (Generic, Show) @@ -106,7 +116,7 @@ instance ToJSON GalleryItem where type ItemProcessor = Path -> IO GalleryItemProps -type ThumbnailProcessor = Path -> IO (Maybe Resource) +type ThumbnailProcessor = Path -> IO (Maybe Thumbnail) buildGalleryTree :: @@ -150,7 +160,7 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in subItemsParents :: [String] subItemsParents = (maybeToList $ fileName path) ++ parentTitles - maybeThumbnail :: Maybe Path -> IO (Maybe Resource) + maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail) maybeThumbnail Nothing = return Nothing maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath @@ -197,10 +207,16 @@ galleryOutputDiff resources ref = resPath :: GalleryItemProps -> Maybe Path resPath Directory{} = Nothing - resPath resourceProps = Just (resourcePath $ resource resourceProps) + resPath resourceProps = + Just + $ resourcePath + $ (resource :: (GalleryItemProps -> Resource)) resourceProps thumbnailPaths :: [GalleryItem] -> [Path] - thumbnailPaths = (map resourcePath) . (mapMaybe thumbnail) + thumbnailPaths = + map resourcePath + . map (resource :: (Thumbnail -> Resource)) + . mapMaybe thumbnail galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () -- cgit v1.2.3 From 9b947996588c02867541ee394aa84fd3839d5f47 Mon Sep 17 00:00:00 2001 From: pacien Date: Sat, 1 Feb 2020 00:00:23 +0100 Subject: compiler: optimise dir diff for output cleanup n log n by sorting instead of silly n^2 GitHub: closes #70 --- compiler/package.yaml | 1 + compiler/src/Resource.hs | 21 ++++++++++++++++++--- 2 files changed, 19 insertions(+), 3 deletions(-) (limited to 'compiler') diff --git a/compiler/package.yaml b/compiler/package.yaml index 9b96d17..1769833 100644 --- a/compiler/package.yaml +++ b/compiler/package.yaml @@ -17,6 +17,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - containers +- data-ordlist - filepath - directory - text diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs index c0ef317..599509e 100644 --- a/compiler/src/Resource.hs +++ b/compiler/src/Resource.hs @@ -24,8 +24,8 @@ module Resource import Control.Concurrent.ParallelIO.Global (parallel) -import Data.List ((\\), sortBy) -import Data.Ord (comparing) +import Data.List (sortOn) +import Data.List.Ordered (minusBy) import Data.Char (toLower) import Data.Maybe (mapMaybe, fromMaybe, maybeToList) import Data.Function ((&)) @@ -202,11 +202,26 @@ galleryOutputDiff resources ref = thumbnailPaths :: [GalleryItem] -> [Path] thumbnailPaths = (map resourcePath) . (mapMaybe thumbnail) + (\\) :: [Path] -> [Path] -> [Path] + a \\ b = minusOn orderedForm (sortOn orderedForm a) (sortOn orderedForm b) + where + orderedForm :: Path -> WebPath + orderedForm = webPath + + minusOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] + minusOn f l r = map snd $ minusBy comparingFst (packRef f l) (packRef f r) + + packRef :: (a -> b) -> [a] -> [(b, a)] + packRef f = map (\x -> let y = f x in y `seq` (y, x)) + + comparingFst :: Ord b => (b, a) -> (b, a) -> Ordering + comparingFst (l, _) (r, _) = compare l r + galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () galleryCleanupResourceDir resourceTree outputDir = readDirectory outputDir >>= return . galleryOutputDiff resourceTree . root - >>= return . sortBy (flip $ comparing pathLength) -- nested files before dirs + >>= return . sortOn ((0 -) . pathLength) -- nested files before their parent dirs >>= return . map (localPath . (/>) outputDir) >>= mapM_ remove -- cgit v1.2.3 From a524bc557ee154d5880153d9b8da680e0b5f3e85 Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 2 Feb 2020 20:58:10 +0100 Subject: compiler: tweak default thumbnail size For better packing. --- compiler/src/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs index d670aae..4c9aa40 100644 --- a/compiler/src/Config.hs +++ b/compiler/src/Config.hs @@ -51,7 +51,7 @@ instance FromJSON CompilerConfig where <*> v .:? "includedFiles" .!= ["*"] <*> v .:? "excludedFiles" .!= [] <*> v .:? "tagsFromDirectories" .!= 0 - <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 400) + <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 300) <*> v .:? "pictureMaxResolution" -- cgit v1.2.3 From 5e85fe0743a2ce0d715ce81d37f02729fce01d9c Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 2 Feb 2020 22:31:15 +0100 Subject: compiler: fix resolution extraction for multilayer images GitHub: closes #84 --- compiler/src/Processors.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index fc719af..16837a6 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -126,9 +126,11 @@ resourceAt fsPath resPath = getModificationTime fsPath >>= return . Resource res getImageResolution :: FilePath -> IO Resolution getImageResolution fsPath = - readProcess "identify" ["-format", "%w %h", fsPath] [] + readProcess "identify" ["-format", "%w %h", firstFrame] [] >>= return . break (== ' ') >>= return . \(w, h) -> Resolution (read w) (read h) + where + firstFrame = fsPath ++ "[0]" type ItemFileProcessor = -- cgit v1.2.3 From c7c872291c2b053afc2c27f999f33b2cfb6c23f1 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 3 Feb 2020 14:27:33 +0100 Subject: compiler: fix viewer output directory exclusion GitHub: closes #87 --- compiler/app/Main.hs | 1 + compiler/src/Compiler.hs | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 10 deletions(-) (limited to 'compiler') diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index e26055f..1864dee 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -103,6 +103,7 @@ main = compileGallery (inputDir opts) (galleryOutputDir opts) + [outputDir opts] (rebuilAll opts) (cleanOutput opts) diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index d392f74..adc4a5f 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -70,10 +70,10 @@ writeJSON outputPath object = ensureParentDir JSON.encodeFile outputPath object -galleryDirFilter :: CompilerConfig -> FilePath -> FSNode -> Bool -galleryDirFilter config outputDir = +galleryDirFilter :: CompilerConfig -> [FilePath] -> FSNode -> Bool +galleryDirFilter config excludedCanonicalDirs = (not . isHidden) - &&& (not . isOutputGallery) + &&& (not . isExcludedDir) &&& (not . matchesFile (== galleryConf)) &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| (matchesFile $ anyPattern $ includedFiles config)) @@ -95,20 +95,20 @@ galleryDirFilter config outputDir = anyPattern :: [String] -> FileName -> Bool anyPattern patterns filename = any (flip Glob.match filename) (map Glob.compile patterns) - isOutputGallery :: FSNode -> Bool - isOutputGallery Dir{canonicalPath} = canonicalPath == outputDir - isOutputGallery File{} = False + isExcludedDir :: FSNode -> Bool + isExcludedDir Dir{canonicalPath} = any (canonicalPath ==) excludedCanonicalDirs + isExcludedDir File{} = False -compileGallery :: FilePath -> FilePath -> Bool -> Bool -> IO () -compileGallery inputDirPath outputDirPath rebuildAll cleanOutput = +compileGallery :: FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO () +compileGallery inputDirPath outputDirPath excludedDirs rebuildAll cleanOutput = do fullConfig <- readConfig inputGalleryConf let config = compiler fullConfig inputDir <- readDirectory inputDirPath - canonicalOutPath <- canonicalizePath outputDirPath - let sourceFilter = galleryDirFilter config canonicalOutPath + excludedCanonicalDirs <- mapM canonicalizePath excludedDirs + let sourceFilter = galleryDirFilter config excludedCanonicalDirs let sourceTree = filterDir sourceFilter inputDir inputTree <- readInputTree sourceTree -- cgit v1.2.3 From bb186990000dd133ecfe6741472b03af92eea233 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 3 Feb 2020 19:00:04 +0100 Subject: compiler: handle image resolution parsing error GitHub: closes #86 --- compiler/src/Processors.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) (limited to 'compiler') diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 16837a6..6ab4eb5 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -24,10 +24,11 @@ module Processors ) where -import Control.Exception (Exception) +import Control.Exception (Exception, throwIO) import Data.Function ((&)) import Data.Char (toLower) import Data.List (break) +import Text.Read (readMaybe) import System.Directory hiding (copyFile) import qualified System.Directory @@ -126,12 +127,18 @@ resourceAt fsPath resPath = getModificationTime fsPath >>= return . Resource res getImageResolution :: FilePath -> IO Resolution getImageResolution fsPath = - readProcess "identify" ["-format", "%w %h", firstFrame] [] - >>= return . break (== ' ') - >>= return . \(w, h) -> Resolution (read w) (read h) + 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 ItemFileProcessor = FileName -- ^ Input base path -- cgit v1.2.3 From b757ee814c01c83b17b495c4805fcc70d7e08c89 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 3 Feb 2020 15:08:46 +0100 Subject: compiler: simplify checks --- compiler/src/Compiler.hs | 8 ++------ compiler/src/Processors.hs | 4 ++-- 2 files changed, 4 insertions(+), 8 deletions(-) (limited to 'compiler') diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs index adc4a5f..2a0dccc 100644 --- a/compiler/src/Compiler.hs +++ b/compiler/src/Compiler.hs @@ -22,7 +22,7 @@ module Compiler ) where -import Control.Monad (liftM2) +import Control.Monad (liftM2, when) import Data.List (any) import System.FilePath (()) import qualified System.FilePath.Glob as Glob @@ -118,11 +118,7 @@ compileGallery inputDirPath outputDirPath excludedDirs rebuildAll cleanOutput = let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config) resources <- galleryBuilder (galleryName config) inputTree - if cleanOutput then - galleryCleanupResourceDir resources outputDirPath - else - return () - + when cleanOutput $ galleryCleanupResourceDir resources outputDirPath writeJSON outputIndex resources writeJSON outputViewerConf $ viewer fullConfig diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs index 6ab4eb5..faa2f43 100644 --- a/compiler/src/Processors.hs +++ b/compiler/src/Processors.hs @@ -25,6 +25,7 @@ module Processors import Control.Exception (Exception, throwIO) +import Control.Monad (when) import Data.Function ((&)) import Data.Char (toLower) import Data.List (break) @@ -106,7 +107,7 @@ withCached :: Cache withCached processor inputPath outputPath = do isDir <- doesDirectoryExist outputPath - if isDir then removePathForcibly outputPath else noop + when isDir $ removePathForcibly outputPath fileExists <- doesFileExist outputPath if fileExists then @@ -117,7 +118,6 @@ withCached processor inputPath outputPath = update where - noop = return () update = processor inputPath outputPath skip = putStrLn $ "Skipping:\t" ++ outputPath -- cgit v1.2.3 From c22ea3de0fc5a42449b4bae80afa1a94c7afa41e Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 3 Feb 2020 15:10:58 +0100 Subject: compiler: reject input and output directories that coincide GitHub: closes #80 --- compiler/app/Main.hs | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) (limited to 'compiler') diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index 1864dee..594a5b7 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -20,11 +20,13 @@ module Main where import GHC.Generics (Generic) import Paths_ldgallery_compiler (version, getDataFileName) +import Control.Monad (when) import Data.Version (showVersion) import Data.Int (Int64) import Data.Aeson (ToJSON) import Data.Time.Clock.System (getSystemTime, systemSeconds) import System.FilePath (()) +import System.Directory (canonicalizePath) import System.Console.CmdArgs import Compiler @@ -88,11 +90,9 @@ main = do opts <- cmdArgs options buildGallery opts - if (withViewer opts) then do + when (withViewer opts) $ do copyViewer (outputDir opts) writeViewerConfig (outputDir opts "config.json") - else - return () where gallerySubdir :: String @@ -100,12 +100,18 @@ main = buildGallery :: Options -> IO () buildGallery opts = - compileGallery - (inputDir opts) - (galleryOutputDir opts) - [outputDir opts] - (rebuilAll opts) - (cleanOutput opts) + checkDistinctPaths (inputDir opts) (outputDir opts) + >> compileGallery + (inputDir opts) + (galleryOutputDir opts) + [outputDir opts] + (rebuilAll opts) + (cleanOutput opts) + where + checkDistinctPaths a b = do + canonicalA <- canonicalizePath a + canonicalB <- canonicalizePath b + when (canonicalA == canonicalB) $ error "Input and output paths refer to the same location." galleryOutputDir :: Options -> FilePath galleryOutputDir opts = -- cgit v1.2.3 From e41b2bc587d058f996bf2ef41e8459d4f6eb7fff Mon Sep 17 00:00:00 2001 From: pacien Date: Thu, 6 Feb 2020 13:51:45 +0100 Subject: compiler: make gallery compilation fail with absent viewer Make the compiler explicitly fail and exit with the proper status code when the viewer is absent and the "--with-viewer" option is used instead of failing silently due to the presence of a placeholder. This commit reverts parts of 2157b66f3ea43137391939992cac4dc901a4ac4e --- compiler/data/viewer/readme.md | 2 -- 1 file changed, 2 deletions(-) delete mode 100644 compiler/data/viewer/readme.md (limited to 'compiler') diff --git a/compiler/data/viewer/readme.md b/compiler/data/viewer/readme.md deleted file mode 100644 index 5786878..0000000 --- a/compiler/data/viewer/readme.md +++ /dev/null @@ -1,2 +0,0 @@ -Missing viewer distribution. -Copy the files in "/viewer/dist/*" here, then rebuild the compiler. -- cgit v1.2.3 From d2ed5f271f49822c9e87058673a006ac80a73876 Mon Sep 17 00:00:00 2001 From: Zero~Informatique Date: Sat, 8 Feb 2020 04:37:22 +0100 Subject: compiler: minor improvements to the CMD scripts --- compiler/win_compile_example.cmd | 11 +++++------ compiler/win_help.cmd | 4 ++++ 2 files changed, 9 insertions(+), 6 deletions(-) create mode 100644 compiler/win_help.cmd (limited to 'compiler') diff --git a/compiler/win_compile_example.cmd b/compiler/win_compile_example.cmd index f5ef2e2..6e166f8 100644 --- a/compiler/win_compile_example.cmd +++ b/compiler/win_compile_example.cmd @@ -1,10 +1,9 @@ @echo off SET rebuild=--rebuild -CHOICE /M "Rebuild all?" +CHOICE /M "Rebuild all ('--rebuild' argument)?" IF ERRORLEVEL 2 SET rebuild= echo. -echo stack exec ldgallery-compiler-exe -- %rebuild% -i=../example/ -o=../example/out/ -echo. -stack exec ldgallery-compiler-exe -- %rebuild% -i=../example/ -o=../example/out/ -echo. -pause + +@echo on +stack exec ldgallery-compiler-exe -- %rebuild% --clean-output -i=../example/ -o=../example/out/ +@pause diff --git a/compiler/win_help.cmd b/compiler/win_help.cmd new file mode 100644 index 0000000..d720f65 --- /dev/null +++ b/compiler/win_help.cmd @@ -0,0 +1,4 @@ +@echo off +stack exec ldgallery-compiler-exe -- --help +@echo. +@pause -- cgit v1.2.3 From 9c2af5dcd2d2c8754e4c74e02141822c0964a5a8 Mon Sep 17 00:00:00 2001 From: Zero~Informatique Date: Thu, 13 Feb 2020 16:30:38 +0100 Subject: moved utility scripts to their dedicated folder --- compiler/win_build.cmd | 4 ---- compiler/win_compile_example.cmd | 9 --------- compiler/win_help.cmd | 4 ---- 3 files changed, 17 deletions(-) delete mode 100644 compiler/win_build.cmd delete mode 100644 compiler/win_compile_example.cmd delete mode 100644 compiler/win_help.cmd (limited to 'compiler') diff --git a/compiler/win_build.cmd b/compiler/win_build.cmd deleted file mode 100644 index 33559fa..0000000 --- a/compiler/win_build.cmd +++ /dev/null @@ -1,4 +0,0 @@ -@echo off -stack setup -stack build -pause \ No newline at end of file diff --git a/compiler/win_compile_example.cmd b/compiler/win_compile_example.cmd deleted file mode 100644 index 6e166f8..0000000 --- a/compiler/win_compile_example.cmd +++ /dev/null @@ -1,9 +0,0 @@ -@echo off -SET rebuild=--rebuild -CHOICE /M "Rebuild all ('--rebuild' argument)?" -IF ERRORLEVEL 2 SET rebuild= -echo. - -@echo on -stack exec ldgallery-compiler-exe -- %rebuild% --clean-output -i=../example/ -o=../example/out/ -@pause diff --git a/compiler/win_help.cmd b/compiler/win_help.cmd deleted file mode 100644 index d720f65..0000000 --- a/compiler/win_help.cmd +++ /dev/null @@ -1,4 +0,0 @@ -@echo off -stack exec ldgallery-compiler-exe -- --help -@echo. -@pause -- cgit v1.2.3 From 7a8bad610472a0197f990dd5f28829f73fc0346e Mon Sep 17 00:00:00 2001 From: pacien Date: Thu, 13 Feb 2020 22:12:20 +0100 Subject: compiler: stabilise item order in index By sorting directory items alphabetically. GitHub: closes #119 --- compiler/src/Files.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs index 8ea943f..8a53b84 100644 --- a/compiler/src/Files.hs ++