From e27f9a220fd8597266d52934bcb06dbe1681b338 Mon Sep 17 00:00:00 2001
From: pacien
Date: Tue, 16 Jun 2020 23:30:32 +0200
Subject: compiler: allow setting thumbnails for all items

Not only for directories.

GitHub: closes #224
---
 compiler/src/Input.hs    | 60 +++++++++++++++++++++++++++++-------------------
 compiler/src/Resource.hs |  8 +++----
 2 files changed, 41 insertions(+), 27 deletions(-)

(limited to 'compiler/src')

diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index 2480f5b..48931ec 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -30,11 +30,12 @@ import Data.Function ((&))
 import Data.Functor ((<&>))
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Bool (bool)
-import Data.List (find)
+import Data.List (find, isSuffixOf)
 import Data.Time.Clock (UTCTime)
 import Data.Time.LocalTime (ZonedTime)
 import Data.Yaml (ParseException, decodeFileEither)
 import Data.Aeson (FromJSON)
+import qualified Data.Map.Strict as Map
 import System.FilePath (isExtensionOf, dropExtension)
 import System.Directory (doesFileExist, getModificationTime)
 
@@ -55,12 +56,13 @@ data InputTree =
     InputFile
       { path :: Path
       , modTime :: UTCTime
-      , sidecar :: Sidecar }
+      , sidecar :: Sidecar
+      , thumbnailPath :: Maybe Path }
     | InputDir
       { path :: Path
       , modTime :: UTCTime
       , sidecar :: Sidecar
-      , dirThumbnailPath :: Maybe Path
+      , thumbnailPath :: Maybe Path
       , items :: [InputTree] }
   deriving Show
 
@@ -81,6 +83,9 @@ emptySidecar = Sidecar
 sidecarExt :: String
 sidecarExt = "yaml"
 
+thumbnailSuffix :: String
+thumbnailSuffix = "_thumbnail"
+
 dirPropFile :: String
 dirPropFile = "_directory"
 
@@ -99,40 +104,49 @@ readInputTree (AnchoredFSNode _ File{}) =
   throw $ AssertionFailed "Input directory is a file"
 readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
   where
-    mkInputNode :: FSNode -> IO (Maybe InputTree)
-    mkInputNode file@File{path}
-      | not (isSidecar file) && not (isThumbnail file) =
-        do
-          sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt)
-          modTime <- getModificationTime $ localPath (anchor /> path)
-          return $ Just $ InputFile path modTime sidecar
-    mkInputNode File{} = return Nothing
-    mkInputNode dir@Dir{} = Just <$> mkDirNode dir
+    mkInputNode :: Map.Map FileName FSNode -> FSNode -> IO (Maybe InputTree)
+    mkInputNode dir file@File{path} | not (isSidecar file) && not (isThumbnail file) =
+      do
+        sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt)
+        modTime <- getModificationTime $ localPath (anchor /> path)
+        let thumbnail = findFileThumbnail (fromMaybe "" $ fileName path) dir
+        return $ Just $ InputFile path modTime sidecar thumbnail
+    mkInputNode _ File{} = return Nothing
+    mkInputNode _ dir@Dir{} = Just <$> mkDirNode dir
 
     mkDirNode :: FSNode -> IO InputTree
     mkDirNode File{} = throw $ AssertionFailed "Input directory is a file"
     mkDirNode Dir{path, items} =
       do
-        dirItems <- mapM mkInputNode items
+        dirItems <- mapM (mkInputNode $ Map.fromList (map withBaseName items)) items
         modTime <- getModificationTime $ localPath (anchor /> path)
         sidecar <- readSidecarFile $ localPath (anchor /> path </> dirSidecar)
-        return $ InputDir path modTime sidecar (findThumbnail items) (catMaybes dirItems)
+        return $ InputDir path modTime sidecar (findDirThumbnail items) (catMaybes dirItems)
+
+    withBaseName :: FSNode -> (FileName, FSNode)
+    withBaseName node = (fromMaybe "" $ baseName $ Files.path node, node)
+
+    findFileThumbnail :: FileName -> Map.Map FileName FSNode -> Maybe Path
+    findFileThumbnail name dict = Files.path <$> Map.lookup (name ++ thumbnailSuffix) dict
 
     isSidecar :: FSNode -> Bool
     isSidecar Dir{} = False
-    isSidecar File{path} =
-      fileName path
-      & maybe False (isExtensionOf sidecarExt)
+    isSidecar File{path} = fileName path & maybe False (isExtensionOf sidecarExt)
+
+    baseName :: Path -> Maybe FileName
+    baseName = fmap dropExtension . fileName
 
     isThumbnail :: FSNode -> Bool
     isThumbnail Dir{} = False
-    isThumbnail File{path} =
-      fileName path
-      & fmap dropExtension
-      & maybe False (dirPropFile ==)
+    isThumbnail File{path} = baseName path & maybe False (thumbnailSuffix `isSuffixOf`)
+
+    isDirThumbnail :: FSNode -> Bool
+    isDirThumbnail Dir{} = False
+    isDirThumbnail File{path} = baseName path & (== Just thumbnailSuffix)
+
+    findDirThumbnail :: [FSNode] -> Maybe Path
+    findDirThumbnail = fmap Files.path . find isDirThumbnail
 
-    findThumbnail :: [FSNode] -> Maybe Path
-    findThumbnail = fmap Files.path . find isThumbnail
 
 -- | Filters an InputTree. The root is always returned.
 filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 6b4b44c..f59eed6 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -134,11 +134,11 @@ buildGalleryTree processItem processThumbnail tagsFromDirsConfig =
   mkGalleryItem []
   where
     mkGalleryItem :: [Tag] -> InputTree -> IO GalleryItem
-    mkGalleryItem inheritedTags InputFile{path, modTime, sidecar} =
+    mkGalleryItem inheritedTags InputFile{path, modTime, sidecar, thumbnailPath} =
       do
         let itemPath = "/" /> path
         properties <- processItem itemPath path
-        processedThumbnail <- processThumbnail itemPath path
+        processedThumbnail <- processThumbnail itemPath (thumbnailPath ?? path)
         return GalleryItem
           { title = Input.title sidecar ?? fileName path ?? ""
           , datetime = Input.datetime sidecar ?? toZonedTime modTime
@@ -148,12 +148,12 @@ buildGalleryTree processItem processThumbnail tagsFromDirsConfig =
           , thumbnail = processedThumbnail
           , properties = properties }
 
-    mkGalleryItem inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
+    mkGalleryItem inheritedTags InputDir{path, modTime, sidecar, thumbnailPath, items} =
       do
         let itemPath = "/" /> path
         let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
         processedItems <- parallel $ map (mkGalleryItem dirTags) items
-        processedThumbnail <- maybeThumbnail itemPath dirThumbnailPath
+        processedThumbnail <- maybeThumbnail itemPath thumbnailPath
         return GalleryItem
           { title = Input.title sidecar ?? fileName path ?? ""
           , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems
-- 
cgit v1.2.3