1 files changed, 201 insertions, 0 deletions

diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs
new file mode 100644
index 0000000..159a425
--- /dev/null
+++ b/compiler/src/Processors.hs
@@ -0,0 +1,201 @@
+-- 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 <https://www.gnu.org/licenses/>.
+
+module Processors
+  ( Resolution(..)
+  , ItemFileProcessor, itemFileProcessor
+  , ThumbnailFileProcessor, thumbnailFileProcessor
+  , skipCached, withCached
+  ) where
+
+
+import Control.Exception (Exception, throwIO)
+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 Resource
+  ( ItemProcessor, ThumbnailProcessor
+  , GalleryItemProps(..), Resolution(..) )
+
+import Files
+
+
+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
+
+formatFromPath :: Path -> Format
+formatFromPath =
+  maybe Unknown fromExt
+  . fmap (map toLower)
+  . fmap takeExtension
+  . 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
+
+
+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
+
+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 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
+  where
+    picWidth = dynamicMap imageWidth image
+    picHeight = dynamicMap imageHeight image
+    resizeRatio = min (boxWidth % picWidth) (boxHeight % picHeight)
+    targetWidth = floor $ resizeRatio * (picWidth % 1)
+    targetHeight = floor $ resizeRatio * (picHeight % 1)
+
+
+type Cache = FileProcessor -> FileProcessor
+
+skipCached :: Cache
+skipCached processor inputPath outputPath =
+  removePathForcibly outputPath
+  >> processor inputPath outputPath
+
+withCached :: Cache
+withCached processor inputPath outputPath =
+  do
+    isDir <- doesDirectoryExist outputPath
+    if isDir then removePathForcibly outputPath else noop
+
+    fileExists <- doesFileExist outputPath
+    if fileExists then
+      do
+        needUpdate <- isOutdated True inputPath outputPath
+        if needUpdate then update else skip
+    else
+      update
+
+  where
+    noop = return ()
+    update = processor inputPath outputPath
+    skip = putStrLn $ "Skipping:\t" ++ outputPath
+
+
+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
+  >> return (props relOutPath)
+  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 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 =
+     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 Path)
+    process Nothing = return Nothing
+    process (Just proc) =
+      proc inPath outPath
+      >> return (Just relOutPath)
+
+    processorFor :: Format -> Maybe FileProcessor
+    processorFor (PictureFormat picFormat) =
+      Just $ resizeStaticImageUpTo picFormat maxRes
+    processorFor _ =
+      Nothing