From 0b2f6fb420d213b4ee718b9ac79cc3f9fa7678d5 Mon Sep 17 00:00:00 2001 From: pacien Date: Wed, 25 Dec 2019 21:04:31 +0100 Subject: compiler: refactor transform stages --- compiler/src/Input.hs | 95 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 compiler/src/Input.hs (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs new file mode 100644 index 0000000..78622bf --- /dev/null +++ b/compiler/src/Input.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-} + +-- ldgallery - A static generator which turns a collection of tagged +-- pictures into a searchable web gallery. +-- +-- Copyright (C) 2019 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 . + + +module Input + ( Sidecar, title, date, description, tags + , InputTree(..), readInputTree + ) where + + +import GHC.Generics (Generic) +import Control.Exception (Exception, throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Function ((&)) +import Data.Maybe (mapMaybe, catMaybes) +import Data.List (find) +import Data.Yaml (ParseException, decodeFileEither) +import Data.Aeson (FromJSON) +import System.FilePath (isExtensionOf, dropExtension) + +import Files +import Utils + + +data LoadException = LoadException String ParseException deriving Show +instance Exception LoadException + +decodeYamlFile :: (MonadIO m, FromJSON a) => Path -> m a +decodeYamlFile path = + liftIO $ Data.Yaml.decodeFileEither fpath + >>= either (throwIO . LoadException fpath) return + where + fpath = localPath path + + +-- | Tree representing the input from the input directory. +data InputTree = + InputFile + { path :: Path + , sidecar :: Sidecar } + | InputDir + { path :: Path + , thumbnailPath :: Maybe Path + , items :: [InputTree] } + deriving Show + +data Sidecar = Sidecar + { title :: Maybe String + , date :: Maybe String + , description :: Maybe String + , tags :: Maybe [String] + } deriving (Generic, FromJSON, Show) + + +readInputTree :: AnchoredFSNode -> IO InputTree +readInputTree (AnchoredFSNode anchor root@Dir{}) = + filterDir (neg isHidden) root & mkDirNode + where + mkInputNode :: FSNode -> IO (Maybe InputTree) + mkInputNode (File path@(filename:pathto)) | ".yaml" `isExtensionOf` filename = + decodeYamlFile (anchor /> path) + >>= return . InputFile ((dropExtension filename):pathto) + >>= return . Just + mkInputNode File{} = return Nothing + mkInputNode dir@Dir{} = mkDirNode dir >>= return . Just + + mkDirNode :: FSNode -> IO InputTree + mkDirNode (Dir path items) = + mapM mkInputNode items + >>= return . catMaybes + >>= return . InputDir path (findThumbnail items) + where + findThumbnail :: [FSNode] -> Maybe Path + findThumbnail = (fmap nodePath) . (find matchThumbnail) + + matchThumbnail :: FSNode -> Bool + matchThumbnail Dir{} = False + matchThumbnail (File (filename:_)) = (dropExtension filename) == "thumbnail" -- cgit v1.2.3 From 5b35285daa62fb9c10280fb43e340ba7b0746f5a Mon Sep 17 00:00:00 2001 From: pacien Date: Wed, 25 Dec 2019 22:48:34 +0100 Subject: compiler: add gallery config file handling --- compiler/src/Input.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 78622bf..fa36d59 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -20,7 +20,8 @@ module Input - ( Sidecar, title, date, description, tags + ( decodeYamlFile + , Sidecar, title, date, description, tags , InputTree(..), readInputTree ) where @@ -42,12 +43,10 @@ import Utils data LoadException = LoadException String ParseException deriving Show instance Exception LoadException -decodeYamlFile :: (MonadIO m, FromJSON a) => Path -> m a +decodeYamlFile :: (MonadIO m, FromJSON a) => FileName -> m a decodeYamlFile path = - liftIO $ Data.Yaml.decodeFileEither fpath - >>= either (throwIO . LoadException fpath) return - where - fpath = localPath path + liftIO $ Data.Yaml.decodeFileEither path + >>= either (throwIO . LoadException path) return -- | Tree representing the input from the input directory. @@ -75,7 +74,7 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = where mkInputNode :: FSNode -> IO (Maybe InputTree) mkInputNode (File path@(filename:pathto)) | ".yaml" `isExtensionOf` filename = - decodeYamlFile (anchor /> path) + decodeYamlFile (localPath $ anchor /> path) >>= return . InputFile ((dropExtension filename):pathto) >>= return . Just mkInputNode File{} = return Nothing -- cgit v1.2.3 From aead07929e6ed13375b86539b1679a88993c9cf5 Mon Sep 17 00:00:00 2001 From: pacien Date: Thu, 26 Dec 2019 08:03:31 +0100 Subject: compiler: extract config and remove utils --- compiler/src/Input.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index fa36d59..681f169 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -37,7 +37,6 @@ import Data.Aeson (FromJSON) import System.FilePath (isExtensionOf, dropExtension) import Files -import Utils data LoadException = LoadException String ParseException deriving Show @@ -70,7 +69,7 @@ data Sidecar = Sidecar readInputTree :: AnchoredFSNode -> IO InputTree readInputTree (AnchoredFSNode anchor root@Dir{}) = - filterDir (neg isHidden) root & mkDirNode + filterDir (not . isHidden) root & mkDirNode where mkInputNode :: FSNode -> IO (Maybe InputTree) mkInputNode (File path@(filename:pathto)) | ".yaml" `isExtensionOf` filename = -- cgit v1.2.3 From eb7a652b2244ffa4dd5ba2440b7879127e7c6078 Mon Sep 17 00:00:00 2001 From: pacien Date: Fri, 27 Dec 2019 10:08:19 +0100 Subject: compiler: implement resource processing but break directory cleanup --- compiler/src/Input.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 681f169..64c1933 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-} - -- ldgallery - A static generator which turns a collection of tagged -- pictures into a searchable web gallery. -- @@ -18,6 +16,11 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE + DuplicateRecordFields + , DeriveGeneric + , DeriveAnyClass +#-} module Input ( decodeYamlFile @@ -55,7 +58,7 @@ data InputTree = , sidecar :: Sidecar } | InputDir { path :: Path - , thumbnailPath :: Maybe Path + , dirThumbnailPath :: Maybe Path , items :: [InputTree] } deriving Show @@ -68,8 +71,7 @@ data Sidecar = Sidecar readInputTree :: AnchoredFSNode -> IO InputTree -readInputTree (AnchoredFSNode anchor root@Dir{}) = - filterDir (not . isHidden) root & mkDirNode +readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) mkInputNode (File path@(filename:pathto)) | ".yaml" `isExtensionOf` filename = -- cgit v1.2.3 From 430ab983587c525004d2aa0dc8e7707312c7ab60 Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 29 Dec 2019 13:53:28 +0100 Subject: compiler: handle empty sidecar files GitHub: closes #1 --- compiler/src/Input.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 64c1933..c90db5c 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -69,13 +69,21 @@ data Sidecar = Sidecar , tags :: Maybe [String] } deriving (Generic, FromJSON, Show) +emptySidecar :: Sidecar +emptySidecar = Sidecar + { title = Nothing + , date = Nothing + , description = Nothing + , tags = Nothing } + readInputTree :: AnchoredFSNode -> IO InputTree readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) mkInputNode (File path@(filename:pathto)) | ".yaml" `isExtensionOf` filename = - decodeYamlFile (localPath $ anchor /> path) + (decodeYamlFile (localPath $ anchor /> path) :: IO (Maybe Sidecar)) + >>= return . maybe emptySidecar id >>= return . InputFile ((dropExtension filename):pathto) >>= return . Just mkInputNode File{} = return Nothing -- cgit v1.2.3 From 54ccbbb9ebde9cb42c5c425266b298668eb3df43 Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 29 Dec 2019 14:21:13 +0100 Subject: compiler: do not require sidecar file GitHub: closes #4 --- compiler/src/Input.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index c90db5c..597394e 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -34,10 +34,12 @@ import Control.Exception (Exception, throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Function ((&)) import Data.Maybe (mapMaybe, catMaybes) +import Data.Bool (bool) import Data.List (find) import Data.Yaml (ParseException, decodeFileEither) import Data.Aeson (FromJSON) import System.FilePath (isExtensionOf, dropExtension) +import System.Directory (doesFileExist) import Files @@ -76,15 +78,23 @@ emptySidecar = Sidecar , description = Nothing , tags = Nothing } +sidecarExt :: String +sidecarExt = "yaml" + +readSidecarFile :: FilePath -> IO Sidecar +readSidecarFile filepath = + doesFileExist filepath + >>= bool (return Nothing) (decodeYamlFile filepath) + >>= return . maybe emptySidecar id + readInputTree :: AnchoredFSNode -> IO InputTree readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) - mkInputNode (File path@(filename:pathto)) | ".yaml" `isExtensionOf` filename = - (decodeYamlFile (localPath $ anchor /> path) :: IO (Maybe Sidecar)) - >>= return . maybe emptySidecar id - >>= return . InputFile ((dropExtension filename):pathto) + mkInputNode (File path@(filename:_)) | not (sidecarExt `isExtensionOf` filename) = + readSidecarFile (localPath $ anchor /> path <.> sidecarExt) + >>= return . InputFile path >>= return . Just mkInputNode File{} = return Nothing mkInputNode dir@Dir{} = mkDirNode dir >>= return . Just -- cgit v1.2.3 From 8a75458290002c765a0fa673912c162020de2bd1 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 30 Dec 2019 01:40:55 +0100 Subject: compiler: refactor path handling --- compiler/src/Input.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 597394e..cb9fc60 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -92,7 +92,7 @@ readInputTree :: AnchoredFSNode -> IO InputTree readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) - mkInputNode (File path@(filename:_)) | not (sidecarExt `isExtensionOf` filename) = + mkInputNode (File path) | not (sidecarExt `isExtensionOf` (fileName path)) = readSidecarFile (localPath $ anchor /> path <.> sidecarExt) >>= return . InputFile path >>= return . Just @@ -110,4 +110,4 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root matchThumbnail :: FSNode -> Bool matchThumbnail Dir{} = False - matchThumbnail (File (filename:_)) = (dropExtension filename) == "thumbnail" + matchThumbnail (File path) = (dropExtension $ fileName path) == "thumbnail" -- cgit v1.2.3 From d0962ef2dea7e8a0c25ca8fdbc55fcbafeeb2f79 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 30 Dec 2019 23:18:49 +0100 Subject: compiler: refactor resource transformation pipeline --- compiler/src/Input.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index cb9fc60..2e11ebe 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -24,7 +24,7 @@ module Input ( decodeYamlFile - , Sidecar, title, date, description, tags + , Sidecar(..) , InputTree(..), readInputTree ) where -- cgit v1.2.3 From abdf82bbfde843a87bd00746f52dafdd28f3f60b Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 5 Jan 2020 15:31:38 +0100 Subject: compiler: make absent file names more explicit --- compiler/src/Input.hs | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 2e11ebe..7e1b169 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 Pacien TRAN-GIRARD +-- 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 @@ -20,6 +20,7 @@ DuplicateRecordFields , DeriveGeneric , DeriveAnyClass + , NamedFieldPuns #-} module Input @@ -92,7 +93,7 @@ readInputTree :: AnchoredFSNode -> IO InputTree readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) - mkInputNode (File path) | not (sidecarExt `isExtensionOf` (fileName path)) = + mkInputNode file@File{path} | not $ isSidecar file = readSidecarFile (localPath $ anchor /> path <.> sidecarExt) >>= return . InputFile path >>= return . Just @@ -104,10 +105,19 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root mapM mkInputNode items >>= return . catMaybes >>= return . InputDir path (findThumbnail items) - where - findThumbnail :: [FSNode] -> Maybe Path - findThumbnail = (fmap nodePath) . (find matchThumbnail) - matchThumbnail :: FSNode -> Bool - matchThumbnail Dir{} = False - matchThumbnail (File path) = (dropExtension $ fileName path) == "thumbnail" + isSidecar :: FSNode -> Bool + isSidecar Dir{} = False + isSidecar File{path} = + fileName path + & (maybe False $ isExtensionOf sidecarExt) + + isThumbnail :: FSNode -> Bool + isThumbnail Dir{} = False + isThumbnail File{path} = + fileName path + & fmap dropExtension + & (maybe False ("thumbnail" ==)) + + findThumbnail :: [FSNode] -> Maybe Path + findThumbnail = (fmap Files.path) . (find isThumbnail) -- cgit v1.2.3 From 9dd271504160b624284dbc438cdc867b6ca0d0e7 Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 5 Jan 2020 16:24:02 +0100 Subject: compiler: enable warnings and fix them GitHub: fixes #9 --- compiler/src/Input.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 7e1b169..ab2bc3c 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -31,10 +31,10 @@ module Input import GHC.Generics (Generic) -import Control.Exception (Exception, throwIO) +import Control.Exception (Exception, AssertionFailed(..), throw, throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Function ((&)) -import Data.Maybe (mapMaybe, catMaybes) +import Data.Maybe (catMaybes) import Data.Bool (bool) import Data.List (find) import Data.Yaml (ParseException, decodeFileEither) @@ -90,6 +90,8 @@ readSidecarFile filepath = readInputTree :: AnchoredFSNode -> IO InputTree +readInputTree (AnchoredFSNode _ File{}) = + throw $ AssertionFailed "Input directory is a file" readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) @@ -101,7 +103,8 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root mkInputNode dir@Dir{} = mkDirNode dir >>= return . Just mkDirNode :: FSNode -> IO InputTree - mkDirNode (Dir path items) = + mkDirNode File{} = throw $ AssertionFailed "Input directory is a file" + mkDirNode Dir{path, items} = mapM mkInputNode items >>= return . catMaybes >>= return . InputDir path (findThumbnail items) -- cgit v1.2.3 From ee222b40569b9f40c482dd9df518f6445c1c304d Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 5 Jan 2020 16:42:09 +0100 Subject: compiler: enable language extensions on whole project --- compiler/src/Input.hs | 7 ------- 1 file changed, 7 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index ab2bc3c..02f79f0 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -16,13 +16,6 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE - DuplicateRecordFields - , DeriveGeneric - , DeriveAnyClass - , NamedFieldPuns -#-} - module Input ( decodeYamlFile , Sidecar(..) -- cgit v1.2.3 From 85a55b5206a401b8726296bd47c307752e09d8b5 Mon Sep 17 00:00:00 2001 From: pacien Date: Sun, 5 Jan 2020 18:39:08 +0100 Subject: compiler: exclude dir thumbnails from items --- compiler/src/Input.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 02f79f0..86d3ec8 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -88,10 +88,11 @@ readInputTree (AnchoredFSNode _ File{}) = readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root where mkInputNode :: FSNode -> IO (Maybe InputTree) - mkInputNode file@File{path} | not $ isSidecar file = - readSidecarFile (localPath $ anchor /> path <.> sidecarExt) - >>= return . InputFile path - >>= return . Just + mkInputNode file@File{path} + | (not $ isSidecar file) && (not $ isThumbnail file) = + readSidecarFile (localPath $ anchor /> path <.> sidecarExt) + >>= return . InputFile path + >>= return . Just mkInputNode File{} = return Nothing mkInputNode dir@Dir{} = mkDirNode dir >>= return . Just -- cgit v1.2.3 From 03d39102ba55cda7cbe80fcdeb9b250caaa70bd0 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 6 Jan 2020 10:28:27 +0100 Subject: compiler: properly reject invalid dates in sidecar files GitHub: closes #31 --- compiler/src/Input.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 86d3ec8..85c802e 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -30,6 +30,7 @@ import Data.Function ((&)) import Data.Maybe (catMaybes) import Data.Bool (bool) import Data.List (find) +import Data.Time.LocalTime (ZonedTime) import Data.Yaml (ParseException, decodeFileEither) import Data.Aeson (FromJSON) import System.FilePath (isExtensionOf, dropExtension) @@ -60,7 +61,7 @@ data InputTree = data Sidecar = Sidecar { title :: Maybe String - , date :: Maybe String + , date :: Maybe ZonedTime , description :: Maybe String , tags :: Maybe [String] } deriving (Generic, FromJSON, Show) -- cgit v1.2.3 From f1ffff03ad6bf86c32c3af90393bd53ca21ad4db Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 6 Jan 2020 11:05:18 +0100 Subject: compiler: rename date field to more explicit datetime --- compiler/src/Input.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 85c802e..95d8132 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -61,7 +61,7 @@ data InputTree = data Sidecar = Sidecar { title :: Maybe String - , date :: Maybe ZonedTime + , datetime :: Maybe ZonedTime , description :: Maybe String , tags :: Maybe [String] } deriving (Generic, FromJSON, Show) @@ -69,7 +69,7 @@ data Sidecar = Sidecar emptySidecar :: Sidecar emptySidecar = Sidecar { title = Nothing - , date = Nothing + , datetime = Nothing , description = Nothing , tags = Nothing } -- cgit v1.2.3 From f5f6ad66b0a5014e9b0da6d5437c27296edab9f0 Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 6 Jan 2020 20:53:37 +0100 Subject: compiler: fix file mod time reading from other directory --- compiler/src/Input.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) (limited to 'compiler/src/Input.hs') diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs index 95d8132..cb837e3 100644 --- a/compiler/src/Input.hs +++ b/compiler/src/Input.hs @@ -30,11 +30,12 @@ import Data.Function ((&)) import Data.Maybe (catMaybes) import Data.Bool (bool) import Data.List (find) +import Data.Time.Clock (UTCTime) import Data.Time.LocalTime (ZonedTime) import Data.Yaml (ParseException, decodeFileEither) import Data.Aeson (FromJSON) import System.FilePath (isExtensionOf, dropExtension) -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, getModificationTime) import Files @@ -52,9 +53,11 @@ decodeYamlFile path = data InputTree = InputFile { path :: Path + , modTime :: UTCTime , sidecar :: Sidecar } | InputDir { path :: Path + , modTime :: UTCTime , dirThumbnailPath :: Maybe Path , items :: [InputTree] } deriving Show @@ -91,18 +94,20 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root mkInputNode :: FSNode -> IO (Maybe InputTree) mkInputNode file@File{path} | (not $ isSidecar file) && (not $ isThumbnail file) = - readSidecarFile (localPath $ anchor /> path <.> sidecarExt) - >>= return . InputFile path - >>= return . Just + 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 mkDirNode :: FSNode -> IO InputTree mkDirNode File{} = throw $ AssertionFailed "Input directory is a file" mkDirNode Dir{path, items} = - mapM mkInputNode items - >>= return . catMaybes - >>= return . InputDir path (findThumbnail items) + do + dirItems <- mapM mkInputNode items + modTime <- getModificationTime $ localPath (anchor /> path) + return $ InputDir path modTime (findThumbnail items) (catMaybes dirItems) isSidecar :: FSNode -> Bool isSidecar Dir{} = False -- cgit v1.2.3