compiler: split ItemProcessors, FileProcessors and Caching

4 files changed, 164 insertions, 105 deletions

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 <https://www.gnu.org/licenses/>.
+
+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 <https://www.gnu.org/licenses/>.
+
+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/Processors.hs b/compiler/src/ItemProcessors.hs
index 73529ee..209bc2a 100644
--- a/compiler/src/Processors.hs
+++ b/compiler/src/ItemProcessors.hs
@@ -16,37 +16,25 @@
 -- 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
+module ItemProcessors
+  ( ItemProcessor
+  , itemFileProcessor
+  , ThumbnailProcessor
+  , thumbnailFileProcessor
   ) 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 System.FilePath (takeExtension)
 
+import Config (Resolution(..))
+import Resource (ItemProcessor, ThumbnailProcessor, Thumbnail(..), GalleryItemProps(..))
+import Caching (Cache)
+import FileProcessors
 import Files
 
 
-data ProcessingException = ProcessingException FilePath String deriving Show
-instance Exception ProcessingException
-
-
 data Format =