1 files changed, 43 insertions, 32 deletions

diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index 6ed7471..7990571 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -1,7 +1,7 @@
 -- ldgallery - A static generator which turns a collection of tagged
 --             pictures into a searchable web gallery.
 --
--- Copyright (C) 2019-2020  Pacien TRAN-GIRARD
+-- Copyright (C) 2019-2022  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
@@ -27,13 +27,15 @@ import GHC.Generics (Generic)
 import Control.Exception (Exception, AssertionFailed(..), throw, throwIO)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Function ((&))
-import Data.Maybe (catMaybes)
+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)
 
@@ -54,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
 
@@ -80,6 +83,9 @@ emptySidecar = Sidecar
 sidecarExt :: String
 sidecarExt = "yaml"
 
+thumbnailSuffix :: String
+thumbnailSuffix = "_thumbnail"
+
 dirPropFile :: String
 dirPropFile = "_directory"
 
@@ -90,48 +96,55 @@ readSidecarFile :: FilePath -> IO Sidecar
 readSidecarFile filepath =
   doesFileExist filepath
   >>= bool (return Nothing) (decodeYamlFile filepath)
-  >>= return . maybe emptySidecar id
+  <&> fromMaybe emptySidecar
 
 
 readInputTree :: AnchoredFSNode -> IO InputTree
-readInputTree (AnchoredFSNode _ File{}) =
-  throw $ AssertionFailed "Input directory is a file"
-readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
+readInputTree (AnchoredFSNode anchor root) = 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{} = mkDirNode dir >>= return . Just
+    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
@@ -140,6 +153,4 @@ filterInputTree cond = filterNode
     filterNode :: InputTree -> InputTree
     filterNode inputFile@InputFile{} = inputFile
     filterNode inputDir@InputDir{items} =
-        filter cond items
-      & map filterNode
-      & \curatedItems -> inputDir { items = curatedItems } :: InputTree
+      inputDir { Input.items = filter cond items & map filterNode }