From 9d2b6cf4641cfff08ad556d3a7b24d4d63464eb5 Mon Sep 17 00:00:00 2001
From: pacien
Date: Tue, 31 Dec 2019 00:16:29 +0100
Subject: compiler: populate the properties field in the index

GitHub: closes #8
---
 compiler/src/Compiler.hs   |  9 +++------
 compiler/src/Processors.hs | 32 ++++++++++++++++++--------------
 compiler/src/Resource.hs   | 10 +++++-----
 3 files changed, 26 insertions(+), 25 deletions(-)

(limited to 'compiler')

diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index 048afc1..f15192f 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -37,7 +37,7 @@ import qualified Data.Aeson as JSON
 
 import Config
 import Input (decodeYamlFile, readInputTree)
-import Resource (GalleryItem, buildGalleryTree, galleryCleanupResourceDir)
+import Resource (buildGalleryTree, galleryCleanupResourceDir)
 import Files
   ( FileName
   , FSNode(..)
@@ -48,11 +48,8 @@ import Files
   , ensureParentDir
   , isOutdated )
 import Processors
-  ( dirFileProcessor
-  , itemFileProcessor
-  , thumbnailFileProcessor
-  , skipCached
-  , withCached )
+  ( dirFileProcessor, itemFileProcessor, thumbnailFileProcessor
+  , skipCached, withCached )
 
 
 writeJSON :: ToJSON a => FileName -> a -> IO ()
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs
index df05c24..dab9aaa 100644
--- a/compiler/src/Processors.hs
+++ b/compiler/src/Processors.hs
@@ -45,6 +45,9 @@ import Codec.Picture
 import Codec.Picture.Extra -- TODO: compare DCT and bilinear (and Lanczos, but it's not implemented)
 
 import Resource
+  ( DirProcessor, ItemProcessor, ThumbnailProcessor
+  , GalleryItemProps(..), Resolution(..) )
+
 import Files
 
 
@@ -54,7 +57,7 @@ instance Exception ProcessingException
 data Format =
     Bmp | Jpg | Png | Tiff | Hdr -- static images
   | Gif -- TODO: might be animated
-  | Other
+  | Unknown
 
 formatFromPath :: Path -> Format
 formatFromPath = aux . (map toLower) . takeExtension . fileName
@@ -66,7 +69,7 @@ formatFromPath = aux . (map toLower) . takeExtension . fileName
     aux ".tiff" = Tiff
     aux ".hdr" = Hdr
     aux ".gif" = Gif
-    aux _ = Other
+    aux _ = Unknown
 
 
 type FileProcessor =
@@ -163,22 +166,23 @@ type ItemFileProcessor =
 
 itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor
 itemFileProcessor maxRes cached inputBase outputBase resClass inputRes =
-  cached (processor maxRes (formatFromPath inputRes)) inPath outPath
-  >> return relOutPath
+  cached processor inPath outPath
+  >> return (relOutPath, props)
   where
     relOutPath = resClass /> inputRes
     inPath = localPath $ inputBase /> inputRes
     outPath = localPath $ outputBase /> relOutPath
-
-    processor :: Maybe Resolution -> Format -> FileProcessor
-    processor Nothing _ = copyFileProcessor
-    processor (Just maxRes) Bmp = resizeStaticImageUpTo Bmp maxRes
-    processor (Just maxRes) Jpg = resizeStaticImageUpTo Jpg maxRes
-    processor (Just maxRes) Png = resizeStaticImageUpTo Png maxRes
-    processor (Just maxRes) Tiff = resizeStaticImageUpTo Tiff maxRes
-    processor (Just maxRes) Hdr = resizeStaticImageUpTo Hdr maxRes
-    processor _ Gif = copyFileProcessor -- TODO: handle animated gif resizing
-    processor _ Other = copyFileProcessor -- TODO: handle video reencoding and others?
+    (processor, props) = formatProcessor maxRes $ 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?
 
 
 type ThumbnailFileProcessor =
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index dcf9422..bffa569 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -25,7 +25,7 @@
 
 module Resource
   ( DirProcessor, ItemProcessor, ThumbnailProcessor
-  , GalleryItem, GalleryItemProps, Resolution(..)
+  , GalleryItem(..), GalleryItemProps(..), Resolution(..)
   , buildGalleryTree, galleryCleanupResourceDir
   ) where
 
@@ -99,7 +99,7 @@ instance ToJSON GalleryItem where
 
 
 type DirProcessor = Path -> IO Path
-type ItemProcessor = Path -> IO Path
+type ItemProcessor = Path -> IO (Path, GalleryItemProps)
 type ThumbnailProcessor = Path -> IO (Maybe Path)
 
 
@@ -115,16 +115,16 @@ buildGalleryTree processDir processItem processThumbnail galleryName inputTree =
     mkGalleryItem :: InputTree -> IO GalleryItem
     mkGalleryItem InputFile{path, sidecar} =
       do
-        processedItem <- processItem path
+        (processedItemPath, properties) <- processItem path
         processedThumbnail <- processThumbnail path
         return GalleryItem
           { title = optMeta title $ fileName path
           , date = optMeta date "" -- TODO: check and normalise dates
           , description = optMeta description ""
           , tags = optMeta tags []
-          , path = processedItem
+          , path = processedItemPath
           , thumbnail = processedThumbnail
-          , properties = Other } -- TODO
+          , properties = properties } -- TODO
       where
         optMeta :: (Sidecar -> Maybe a) -> a -> a
         optMeta get fallback = fromMaybe fallback $ get sidecar
-- 
cgit v1.2.3