From 2a336b297237b546f065f706838f4cefad4c3e7c Mon Sep 17 00:00:00 2001
From: pacien
Date: Sat, 25 Jan 2020 13:47:27 +0100
Subject: compiler: add resource timestamp in generated index

Add a timestamp to resource paths in the gallery index to invalidate
elements in the browser's cache when necessary.

Timestamps are added to resource URLs as a dummy numeric parameter.

GitHub: closes #40
---
 compiler/src/Resource.hs | 40 +++++++++++++++++++++++++++-------------
 1 file changed, 27 insertions(+), 13 deletions(-)

(limited to 'compiler/src/Resource.hs')

diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 56f7a3f..c0ef317 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -18,7 +18,7 @@
 
 module Resource
   ( ItemProcessor, ThumbnailProcessor
-  , GalleryItem(..), GalleryItemProps(..), Resolution(..)
+  , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..)
   , buildGalleryTree, galleryCleanupResourceDir
   ) where
 
@@ -30,8 +30,10 @@ import Data.Char (toLower)
 import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
 import Data.Function ((&))
 import qualified Data.Set as Set
+import Data.Text (pack)
 import Data.Time.Clock (UTCTime)
 import Data.Time.LocalTime (ZonedTime, utc, utcToZonedTime, zonedTimeToUTC)
+import Data.Time.Format (formatTime, defaultTimeLocale)
 import Safe.Foldable (maximumByMay)
 
 import GHC.Generics (Generic)
@@ -65,10 +67,22 @@ instance ToJSON Resolution where
   toEncoding = genericToEncoding encodingOptions
 
 
+data Resource = Resource
+  { resourcePath :: Path
+  , modTime :: UTCTime
+  } deriving (Generic, Show)
+
+instance ToJSON Resource where
+  toJSON Resource{resourcePath, modTime} =
+    JSON.String $ pack (webPath resourcePath ++ "?" ++ timestamp)
+    where
+      timestamp = formatTime defaultTimeLocale "%s" modTime
+
+
 data GalleryItemProps =
     Directory { items :: [GalleryItem] }
-  | Picture { resource :: Path }
-  | Other { resource :: Path }
+  | Picture { resource :: Resource }
+  | Other { resource :: Resource }
   deriving (Generic, Show)
 
 instance ToJSON GalleryItemProps where
@@ -82,7 +96,7 @@ data GalleryItem = GalleryItem
   , description :: String
   , tags :: [Tag]
   , path :: Path
-  , thumbnail :: Maybe Path
+  , thumbnail :: Maybe Resource
   , properties :: GalleryItemProps
   } deriving (Generic, Show)
 
@@ -92,7 +106,7 @@ instance ToJSON GalleryItem where
 
 
 type ItemProcessor = Path -> IO GalleryItemProps
-type ThumbnailProcessor = Path -> IO (Maybe Path)
+type ThumbnailProcessor = Path -> IO (Maybe Resource)
 
 
 buildGalleryTree ::
@@ -136,7 +150,7 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in
         subItemsParents :: [String]
         subItemsParents = (maybeToList $ fileName path) ++ parentTitles
 
-    maybeThumbnail :: Maybe Path -> IO (Maybe Path)
+    maybeThumbnail :: Maybe Path -> IO (Maybe Resource)
     maybeThumbnail Nothing = return Nothing
     maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath
 
@@ -175,18 +189,18 @@ galleryOutputDiff resources ref =
 
     compiledPaths :: [GalleryItem] -> [Path]
     compiledPaths items =
-      resourcePaths items ++ thumbnailPaths items
+      resPaths items ++ thumbnailPaths items
       & concatMap subPaths
 
-    resourcePaths :: [GalleryItem] -> [Path]
-    resourcePaths = mapMaybe (resourcePath . properties)
+    resPaths :: [GalleryItem] -> [Path]
+    resPaths = mapMaybe (resPath . properties)
 
-    resourcePath :: GalleryItemProps -> Maybe Path
-    resourcePath Directory{} = Nothing
-    resourcePath resourceProps = Just $ resource resourceProps
+    resPath :: GalleryItemProps -> Maybe Path
+    resPath Directory{} = Nothing
+    resPath resourceProps = Just (resourcePath $ resource resourceProps)
 
     thumbnailPaths :: [GalleryItem] -> [Path]
-    thumbnailPaths = mapMaybe thumbnail
+    thumbnailPaths = (map resourcePath) . (mapMaybe thumbnail)
 
 
 galleryCleanupResourceDir :: GalleryItem -> FileName -> IO ()
-- 
cgit v1.2.3


From 7dde692101a7e36e0a431aeb864cbf3a0c0e96f8 Mon Sep 17 00:00:00 2001
From: pacien
Date: Fri, 31 Jan 2020 19:43:24 +0100
Subject: compiler: add thumbnail size to index

---
 compiler/src/Resource.hs | 28 ++++++++++++++++++++++------
 1 file changed, 22 insertions(+), 6 deletions(-)

(limited to 'compiler/src/Resource.hs')

diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index c0ef317..33f3cf0 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -18,7 +18,7 @@
 
 module Resource
   ( ItemProcessor, ThumbnailProcessor
-  , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..)
+  , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..)
   , buildGalleryTree, galleryCleanupResourceDir
   ) where
 
@@ -90,13 +90,23 @@ instance ToJSON GalleryItemProps where
   toEncoding = genericToEncoding encodingOptions
 
 
+data Thumbnail = Thumbnail
+  { resource :: Resource
+  , resolution :: Resolution
+  } deriving (Generic, Show)
+
+instance ToJSON Thumbnail where
+  toJSON = genericToJSON encodingOptions
+  toEncoding = genericToEncoding encodingOptions
+
+
 data GalleryItem = GalleryItem
   { title :: String
   , datetime :: ZonedTime
   , description :: String
   , tags :: [Tag]
   , path :: Path
-  , thumbnail :: Maybe Resource
+  , thumbnail :: Maybe Thumbnail
   , properties :: GalleryItemProps
   } deriving (Generic, Show)
 
@@ -106,7 +116,7 @@ instance ToJSON GalleryItem where
 
 
 type ItemProcessor = Path -> IO GalleryItemProps
-type ThumbnailProcessor = Path -> IO (Maybe Resource)
+type ThumbnailProcessor = Path -> IO (Maybe Thumbnail)
 
 
 buildGalleryTree ::
@@ -150,7 +160,7 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in
         subItemsParents :: [String]
         subItemsParents = (maybeToList $ fileName path) ++ parentTitles
 
-    maybeThumbnail :: Maybe Path -> IO (Maybe Resource)
+    maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail)
     maybeThumbnail Nothing = return Nothing
     maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath
 
@@ -197,10 +207,16 @@ galleryOutputDiff resources ref =
 
     resPath :: GalleryItemProps -> Maybe Path
     resPath Directory{} = Nothing
-    resPath resourceProps = Just (resourcePath $ resource resourceProps)
+    resPath resourceProps =
+        Just
+      $ resourcePath
+      $ (resource :: (GalleryItemProps -> Resource)) resourceProps
 
     thumbnailPaths :: [GalleryItem] -> [Path]
-    thumbnailPaths = (map resourcePath) . (mapMaybe thumbnail)
+    thumbnailPaths =
+        map resourcePath
+      . map (resource :: (Thumbnail -> Resource))
+      . mapMaybe thumbnail
 
 
 galleryCleanupResourceDir :: GalleryItem -> FileName -> IO ()
-- 
cgit v1.2.3


From 9b947996588c02867541ee394aa84fd3839d5f47 Mon Sep 17 00:00:00 2001
From: pacien
Date: Sat, 1 Feb 2020 00:00:23 +0100
Subject: compiler: optimise dir diff for output cleanup

n log n by sorting instead of silly n^2

GitHub: closes #70
---
 compiler/src/Resource.hs | 21 ++++++++++++++++++---
 1 file changed, 18 insertions(+), 3 deletions(-)

(limited to 'compiler/src/Resource.hs')

diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index c0ef317..599509e 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -24,8 +24,8 @@ module Resource
 
 
 import Control.Concurrent.ParallelIO.Global (parallel)
-import Data.List ((\\), sortBy)
-import Data.Ord (comparing)
+import Data.List (sortOn)
+import Data.List.Ordered (minusBy)
 import Data.Char (toLower)
 import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
 import Data.Function ((&))
@@ -202,11 +202,26 @@ galleryOutputDiff resources ref =
     thumbnailPaths :: [GalleryItem] -> [Path]
     thumbnailPaths = (map resourcePath) . (mapMaybe thumbnail)
 
+    (\\) :: [Path] -> [Path] -> [Path]
+    a \\ b = minusOn orderedForm (sortOn orderedForm a) (sortOn orderedForm b)
+      where
+        orderedForm :: Path -> WebPath
+        orderedForm = webPath
+
+        minusOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
+        minusOn f l r = map snd $ minusBy comparingFst (packRef f l) (packRef f r)
+
+        packRef :: (a -> b) -> [a] -> [(b, a)]
+        packRef f = map (\x -> let y = f x in y `seq` (y, x))
+
+        comparingFst :: Ord b => (b, a) -> (b, a) -> Ordering
+        comparingFst (l, _) (r, _) = compare l r
+
 
 galleryCleanupResourceDir :: GalleryItem -> FileName -> IO ()
 galleryCleanupResourceDir resourceTree outputDir =
   readDirectory outputDir
   >>= return . galleryOutputDiff resourceTree . root
-  >>= return . sortBy (flip $ comparing pathLength) -- nested files before dirs
+  >>= return . sortOn ((0 -) . pathLength) -- nested files before their parent dirs
   >>= return . map (localPath . (/>) outputDir)
   >>= mapM_ remove
-- 
cgit v1.2.3


From 395a76bc4193c0c7182f87778458a68d0079e836 Mon Sep 17 00:00:00 2001
From: pacien
Date: Fri, 14 Feb 2020 15:39:56 +0100
Subject: compiler: metadata sidecar for whole directories

GitHub: closes #3
---
 compiler/src/Resource.hs | 61 ++++++++++++++++++++++++------------------------
 1 file changed, 30 insertions(+), 31 deletions(-)

(limited to 'compiler/src/Resource.hs')

diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 400e18a..aadf60b 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -121,44 +121,52 @@ type ThumbnailProcessor = Path -> IO (Maybe Thumbnail)
 
 buildGalleryTree ::
      ItemProcessor -> ThumbnailProcessor
-  -> Int -> String -> InputTree -> IO GalleryItem
-buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree =
-  mkGalleryItem [] inputTree
+  -> Int -> InputTree -> IO GalleryItem
+buildGalleryTree processItem processThumbnail tagsFromDirectories inputTree =
+  mkGalleryItem [] [] inputTree
   where
-    mkGalleryItem :: [String] -> InputTree -> IO GalleryItem
-    mkGalleryItem parentTitles InputFile{path, modTime, sidecar} =
+    mkGalleryItem :: [String] -> [Tag] -> InputTree -> IO GalleryItem
+    mkGalleryItem parentDirs inheritedTags InputFile{path, modTime, sidecar} =
       do
         properties <- processItem path
         processedThumbnail <- processThumbnail path
         return GalleryItem
-          { title = fromMeta title $ fromMaybe "" $ fileName path
-          , datetime = fromMaybe (toZonedTime modTime) (Input.datetime sidecar)
-          , description = fromMeta description ""
-          , tags = unique ((fromMeta tags []) ++ implicitParentTags parentTitles)
+          { title = Input.title sidecar ?? fileName path ?? ""
+          , datetime = Input.datetime sidecar ?? toZonedTime modTime
+          , description = Input.description sidecar ?? ""
+          , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags parentDirs)
           , path = "/" /> path
           , thumbnail = processedThumbnail
           , properties = properties }
 
-      where
-        fromMeta :: (Sidecar -> Maybe a) -> a -> a
-        fromMeta get fallback = fromMaybe fallback $ get sidecar
-
-    mkGalleryItem parentTitles InputDir{path, modTime, dirThumbnailPath, items} =
+    mkGalleryItem parentDirs inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
       do
+        let itemsParents = (maybeToList $ fileName path) ++ parentDirs
+        let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
+        processedItems <- parallel $ map (mkGalleryItem itemsParents dirTags) items
         processedThumbnail <- maybeThumbnail dirThumbnailPath
-        processedItems <- parallel $ map (mkGalleryItem subItemsParents) items
         return GalleryItem
-          { title = fromMaybe galleryName (fileName path)
-          , datetime = fromMaybe (toZonedTime modTime) (mostRecentModTime processedItems)
-          , description = ""
-          , tags = unique (aggregateTags processedItems ++ implicitParentTags parentTitles)
+          { title = Input.title sidecar ?? fileName path ?? ""
+          , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems
+                                              ?? toZonedTime modTime
+          , description = Input.description sidecar ?? ""
+          , tags = unique (aggregateTags processedItems ++ parentDirTags parentDirs)
           , path = "/" /> path
           , thumbnail = processedThumbnail
           , properties = Directory processedItems }
 
-      where
-        subItemsParents :: [String]
-        subItemsParents = (maybeToList $ fileName path) ++ parentTitles
+    infixr ??
+    (??) :: Maybe a -> a -> a
+    (??) = flip fromMaybe
+
+    unique :: Ord a => [a] -> [a]
+    unique = Set.toList . Set.fromList
+
+    parentDirTags :: [String] -> [Tag]
+    parentDirTags = take tagsFromDirectories
+
+    aggregateTags :: [GalleryItem] -> [Tag]
+    aggregateTags = concatMap (\item -> tags (item::GalleryItem))
 
     maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail)
     maybeThumbnail Nothing = return Nothing
@@ -171,15 +179,6 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in
     comparingTime :: ZonedTime -> ZonedTime -> Ordering
     comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r)
 
-    aggregateTags :: [GalleryItem] -> [Tag]
-    aggregateTags = concatMap (\item -> tags (item::GalleryItem))
-
-    unique :: Ord a => [a] -> [a]
-    unique = Set.toList . Set.fromList
-
-    implicitParentTags :: [String] -> [Tag]
-    implicitParentTags = take tagsFromDirectories
-
     toZonedTime :: UTCTime -> ZonedTime
     toZonedTime = utcToZonedTime utc
 
-- 
cgit v1.2.3


From 68899f0c1ba4f641c376fda1e51d9694b02b9c5d Mon Sep 17 00:00:00 2001
From: pacien
Date: Mon, 17 Feb 2020 18:09:20 +0100
Subject: compiler: add a prefix setting for tags generated from parent dirs

GitHub: closes #59
---
 compiler/src/Resource.hs | 43 ++++++++++++++++++-------------------------
 1 file changed, 18 insertions(+), 25 deletions(-)

(limited to 'compiler/src/Resource.hs')

diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index aadf60b..b2a6bbf 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -27,7 +27,7 @@ import Control.Concurrent.ParallelIO.Global (parallel)
 import Data.List (sortOn)
 import Data.List.Ordered (minusBy)
 import Data.Char (toLower)
-import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
+import Data.Maybe (mapMaybe, fromMaybe)
 import Data.Function ((&))
 import qualified Data.Set as Set
 import Data.Text (pack)
@@ -37,10 +37,11 @@ import Data.Time.Format (formatTime, defaultTimeLocale)
 import Safe.Foldable (maximumByMay)
 
 import GHC.Generics (Generic)
-import Data.Aeson (FromJSON, ToJSON, genericToJSON, genericToEncoding)
+import Data.Aeson (ToJSON, genericToJSON, genericToEncoding)
 import qualified Data.Aeson as JSON
 
 import Files
+import Config (Resolution(..), TagsFromDirectoriesConfig(..))
 import Input (InputTree(..), Sidecar(..))
 
 
@@ -57,16 +58,6 @@ encodingOptions = JSON.defaultOptions
 
 type Tag = String
 
-data Resolution = Resolution
-  { width :: Int
-  , height :: Int
-  } deriving (Generic, Show, FromJSON)
-
-instance ToJSON Resolution where
-  toJSON = genericToJSON encodingOptions
-  toEncoding = genericToEncoding encodingOptions
-
-
 data Resource = Resource
   { resourcePath :: Path
   , modTime :: UTCTime
@@ -120,13 +111,13 @@ type ThumbnailProcessor = Path -> IO (Maybe Thumbnail)
 
 
 buildGalleryTree ::
-     ItemProcessor -> ThumbnailProcessor
-  -> Int -> InputTree -> IO GalleryItem
-buildGalleryTree processItem processThumbnail tagsFromDirectories inputTree =
-  mkGalleryItem [] [] inputTree
+     ItemProcessor -> ThumbnailProcessor -> TagsFromDirectoriesConfig
+  -> InputTree -> IO GalleryItem
+buildGalleryTree processItem processThumbnail tagsFromDirsConfig inputTree =
+  mkGalleryItem [] inputTree
   where
-    mkGalleryItem :: [String] -> [Tag] -> InputTree -> IO GalleryItem
-    mkGalleryItem parentDirs inheritedTags InputFile{path, modTime, sidecar} =
+    mkGalleryItem :: [Tag] -> InputTree -> IO GalleryItem
+    mkGalleryItem inheritedTags InputFile{path, modTime, sidecar} =
       do
         properties <- processItem path
         processedThumbnail <- processThumbnail path
@@ -134,23 +125,22 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories inputTree =
           { title = Input.title sidecar ?? fileName path ?? ""
           , datetime = Input.datetime sidecar ?? toZonedTime modTime
           , description = Input.description sidecar ?? ""
-          , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags parentDirs)
+          , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags path)
           , path = "/" /> path
           , thumbnail = processedThumbnail
           , properties = properties }
 
-    mkGalleryItem parentDirs inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
+    mkGalleryItem inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
       do
-        let itemsParents = (maybeToList $ fileName path) ++ parentDirs
         let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
-        processedItems <- parallel $ map (mkGalleryItem itemsParents dirTags) items
+        processedItems <- parallel $ map (mkGalleryItem dirTags) items
         processedThumbnail <- maybeThumbnail dirThumbnailPath
         return GalleryItem
           { title = Input.title sidecar ?? fileName path ?? ""
           , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems
                                               ?? toZonedTime modTime
           , description = Input.description sidecar ?? ""
-          , tags = unique (aggregateTags processedItems ++ parentDirTags parentDirs)
+          , tags = unique (aggregateTags processedItems ++ parentDirTags path)
           , path = "/" /> path
           , thumbnail = processedThumbnail
           , properties = Directory processedItems }
@@ -162,8 +152,11 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories inputTree =
     unique :: Ord a => [a] -> [a]
     unique = Set.toList . Set.fromList
 
-    parentDirTags :: [String] -> [Tag]
-    parentDirTags = take tagsFromDirectories
+    parentDirTags :: Path -> [Tag]
+    parentDirTags (Path elements) =
+        drop 1 elements
+      & take (fromParents tagsFromDirsConfig)
+      & map (prefix tagsFromDirsConfig ++)
 
     aggregateTags :: [GalleryItem] -> [Tag]
     aggregateTags = concatMap (\item -> tags (item::GalleryItem))
-- 
cgit v1.2.3


From 579df471dee7b6fe0be8a9ad8e2fa2362c9bf6cd Mon Sep 17 00:00:00 2001
From: pacien
Date: Tue, 28 Apr 2020 00:14:31 +0200
Subject: compiler: add picture size to index

This is needed for the picture viewer fancy loading phase.
---
 compiler/src/Resource.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'compiler/src/Resource.hs')

diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index b2a6bbf..e134468 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -72,7 +72,9 @@ instance ToJSON Resource where
 
 data GalleryItemProps =
     Directory { items :: [GalleryItem] }
-  | Picture { resource :: Resource }
+  | Picture
+    { resource :: Resource
+    , resolution :: Resolution }
   | Other { resource :: Resource }
   deriving (Generic, Show)
 
-- 
cgit v1.2.3