From f09e9d9fa29284bd9ae872efe5ba1d526e349011 Mon Sep 17 00:00:00 2001
From: pacien
Date: Wed, 26 Feb 2020 22:13:00 +0100
Subject: compiler: add tag inclusion and exclusion globs

GitHub: closes #30
---
 compiler/src/Compiler.hs | 30 ++++++++++++++++++++++--------
 compiler/src/Config.hs   |  4 ++++
 compiler/src/Input.hs    | 13 ++++++++++++-
 3 files changed, 38 insertions(+), 9 deletions(-)

(limited to 'compiler/src')

diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index 51f5065..fa405a2 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -25,6 +25,7 @@ module Compiler
 import GHC.Generics (Generic)
 import Control.Monad (liftM2, when)
 import Data.List (any)
+import Data.Maybe (fromMaybe)
 import System.FilePath ((</>))
 import qualified System.FilePath.Glob as Glob
 import System.Directory (canonicalizePath)
@@ -33,7 +34,7 @@ import Data.Aeson (ToJSON)
 import qualified Data.Aeson as JSON
 
 import Config
-import Input (readInputTree)
+import Input (InputTree, readInputTree, filterInputTree, sidecar, tags)
 import Resource (GalleryItem, buildGalleryTree, galleryCleanupResourceDir)
 import Files
   ( FileName
@@ -74,6 +75,15 @@ writeJSON outputPath object =
     ensureParentDir JSON.encodeFile outputPath object
 
 
+(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
+(&&&) = liftM2 (&&)
+
+(|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
+(|||) = liftM2 (||)
+
+anyPattern :: [String] -> String -> Bool
+anyPattern patterns string = any (flip Glob.match string) (map Glob.compile patterns)
+
 galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool
 galleryDirFilter config excludedCanonicalDirs =
       (not . isHidden)
@@ -84,9 +94,6 @@ galleryDirFilter config excludedCanonicalDirs =
               (matchesFile $ anyPattern $ excludedFiles config)))
 
   where
-    (&&&) = liftM2 (&&)
-    (|||) = liftM2 (||)
-
     matchesDir :: (FileName -> Bool) -> FSNode -> Bool
     matchesDir cond dir@Dir{} = maybe False cond $ nodeName dir
     matchesDir _ File{} = False
@@ -95,13 +102,19 @@ galleryDirFilter config excludedCanonicalDirs =
     matchesFile cond file@File{} = maybe False cond $ nodeName file
     matchesFile _ Dir{} = False
 
-    anyPattern :: [String] -> FileName -> Bool
-    anyPattern patterns filename = any (flip Glob.match filename) (map Glob.compile patterns)
-
     isExcludedDir :: FSNode -> Bool
     isExcludedDir Dir{canonicalPath} = any (canonicalPath ==) excludedCanonicalDirs
     isExcludedDir File{} = False
 
+inputTreeFilter :: GalleryConfig -> InputTree -> Bool
+inputTreeFilter GalleryConfig{includedTags, excludedTags} =
+      (hasTagMatching $ anyPattern includedTags)
+  &&& (not . (hasTagMatching $ anyPattern excludedTags))
+
+  where
+    hasTagMatching :: (String -> Bool) -> InputTree -> Bool
+    hasTagMatching cond = (any cond) . (fromMaybe [""] . tags) . sidecar
+
 
 compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO ()
 compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDirs rebuildAll cleanOutput =
@@ -113,12 +126,13 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir
     let sourceFilter = galleryDirFilter config excludedCanonicalDirs
     let sourceTree = filterDir sourceFilter inputDir
     inputTree <- readInputTree sourceTree
+    let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree
 
     let cache = if rebuildAll then skipCached else withCached
     let itemProc = itemProcessor config cache
     let thumbnailProc = thumbnailProcessor config cache
     let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config)
-    resources <- galleryBuilder inputTree
+    resources <- galleryBuilder curatedInputTree
 
     when cleanOutput $ galleryCleanupResourceDir resources outputDirPath
     writeJSON (outputGalleryIndex outputIndexPath) $ GalleryIndex (viewerConfig config) resources
diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs
index 1bdb2b8..8796c3c 100644
--- a/compiler/src/Config.hs
+++ b/compiler/src/Config.hs
@@ -55,6 +55,8 @@ data GalleryConfig = GalleryConfig
   , excludedDirectories :: [String]
   , includedFiles :: [String]
   , excludedFiles :: [String]
+  , includedTags :: [String]
+  , excludedTags :: [String]
   , tagsFromDirectories :: TagsFromDirectoriesConfig
   , thumbnailMaxResolution :: Resolution
   , pictureMaxResolution :: Maybe Resolution
@@ -67,6 +69,8 @@ instance FromJSON GalleryConfig where
     <*> v .:? "excludedDirectories" .!= []
     <*> v .:? "includedFiles" .!= ["*"]
     <*> v .:? "excludedFiles" .!= []
+    <*> v .:? "includedTags" .!= ["*"]
+    <*> v .:? "excludedTags" .!= []
     <*> v .:? "tagsFromDirectories" .!= (TagsFromDirectoriesConfig 0 "")
     <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 300)
     <*> v .:? "pictureMaxResolution"
diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index 75d1ed3..6ed7471 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -19,7 +19,7 @@
 module Input
   ( decodeYamlFile
   , Sidecar(..)
-  , InputTree(..), readInputTree
+  , InputTree(..), readInputTree, filterInputTree
   ) where
 
 
@@ -132,3 +132,14 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
 
     findThumbnail :: [FSNode] -> Maybe Path
     findThumbnail = (fmap Files.path) . (find isThumbnail)
+
+-- | Filters an InputTree. The root is always returned.
+filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree
+filterInputTree cond = filterNode
+  where
+    filterNode :: InputTree -> InputTree
+    filterNode inputFile@InputFile{} = inputFile
+    filterNode inputDir@InputDir{items} =
+        filter cond items
+      & map filterNode
+      & \curatedItems -> inputDir { items = curatedItems } :: InputTree
-- 
cgit v1.2.3