From 67f0c3ded792672e85ed1e5a2a9efb4186d01d5e Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Tue, 5 Nov 2024 00:21:35 +0100 Subject: [PATCH] implement tag aliases, replacements, warnings warnings are printed by `list-tags` --- Makefile | 7 +- make-pages/GalleryPage.hs | 12 ++- make-pages/Info.hs | 172 +++++++++++++++++++++++------------- make-pages/ListTags.hs | 55 ++++++++---- make-pages/Main.hs | 40 +++++---- make-pages/Options.hs | 11 ++- make-pages/SinglePage.hs | 34 +++---- make-pages/TagTransforms.hs | 103 +++++++++++++++++++++ make-pages/make-pages.cabal | 3 + 9 files changed, 319 insertions(+), 118 deletions(-) create mode 100644 make-pages/TagTransforms.hs diff --git a/Makefile b/Makefile index 0572da0..0413614 100644 --- a/Makefile +++ b/Makefile @@ -5,6 +5,7 @@ TMPDIR := _tmp BUILDDIR := _build INFONAME := info.yaml ROOT := https://gallery.niss.website +INDEX := $(DATADIR)/index.yaml # SMALL = thumbnails, MED = single pages (link to full size) SMALL := 200 @@ -28,7 +29,7 @@ BSCRIPTS = $(patsubst %.ts,$(BUILDDIR)/%.js,$(TSCRIPTS)) all: build build: $(BUILDDIR)/index.html $(BSTATIC) $(BSCRIPTS) -$(BUILDDIR)/index.html: $(DATADIR)/index.yaml $(MAKEPAGES) +$(BUILDDIR)/index.html: $(INDEX) $(MAKEPAGES) echo "[index] "$@ mkdir -p $(dir $@) $(MAKEPAGES) $(MPFLAGS) index --root $(ROOT) $< --output $@ @@ -85,7 +86,7 @@ $(MAKEPAGES): make-pages/*.hs make-pages/make-pages.cabal -exec cp {} $@ \; -$(TMPDIR)/index.mk: $(DATADIR)/index.yaml $(YAMLS) $(MAKEPAGES) +$(TMPDIR)/index.mk: $(INDEX) $(YAMLS) $(MAKEPAGES) $(call depend-gallery) NODEPS := mostlyclean clean distclean list-tags @@ -109,7 +110,7 @@ distclean: clean .PHONY: list-tags list-tags: $(MAKEPAGES) - $(MAKEPAGES) list-tags --untagged --nsfw + $(MAKEPAGES) list-tags --untagged --warnings --nsfw --index $(INDEX) HOST ?= gallery.niss.website diff --git a/make-pages/GalleryPage.hs b/make-pages/GalleryPage.hs index 0b4d784..9f81728 100644 --- a/make-pages/GalleryPage.hs +++ b/make-pages/GalleryPage.hs @@ -1,15 +1,16 @@ +{-# LANGUAGE RecordWildCards #-} module GalleryPage (make) where import BuilderQQ import Date import Info import qualified NsfwWarning +import TagTransforms import Control.Monad import Data.Foldable import Data.Function ((&)) import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (intersperse, sort, sortOn) import Data.Maybe @@ -17,12 +18,15 @@ import Data.Ord (Down (..)) import qualified Data.Text.Lazy as Lazy import System.FilePath (takeDirectory, joinPath, splitPath) -make :: Text -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text -make root ginfo infos = toLazyText $ make' root ginfo infos +make :: Text -> IndexInfo -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text +make root iinfo ginfo infos = + toLazyText $ make' root ginfo $ + map (fmap $ transformInfoTags iinfo.tags) infos make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder -make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b| +make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = + [b| diff --git a/make-pages/Info.hs b/make-pages/Info.hs index b326b97..1b0b6fa 100644 --- a/make-pages/Info.hs +++ b/make-pages/Info.hs @@ -1,6 +1,5 @@ -{-# OPTIONS_GHC -fdefer-typed-holes #-} - {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE PatternSynonyms #-} module Info (Info (..), anySfw, anyNsfw, allSfw, allNsfw, @@ -20,18 +19,23 @@ module Info GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..), readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, + TagTransforms (..), emptyTransforms, + Implies (..), Replacement (..), Warning (..), + IndexInfo (..), NoThumb (..), getThumb, thumbFile, pageFile, bigFile, -- ** Reexports - Date (..), Day (..), Text, NonEmpty (..)) + Date (..), Day (..), Text, NonEmpty (..), Regex, HashSet, HashMap) where import Date + import Control.Applicative import Control.Exception import Control.Monad import Data.Bitraversable (bitraverse) +import Data.Char qualified as Char import Data.Foldable (find) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap @@ -53,6 +57,7 @@ import Data.YAML (FromYAML (..), (.:), (.:?), (.!=)) import Data.YAML qualified as YAML import GHC.Records import System.FilePath ((), takeBaseName, takeExtension, splitExtension) +import Text.ParserCombinators.ReadP qualified as ReadP import Text.Regex.TDFA (Regex) import Text.Regex.TDFA qualified as Regex @@ -75,6 +80,7 @@ data Info = nsfwOnly :: !Bool, tags :: !(HashSet Text), nsfwTags :: !(HashSet Text), + excludeTags :: !(HashSet Text), -- remove tags that would be implied desc :: !Desc, nsfwDesc :: !Desc, bg :: !Bg, @@ -315,8 +321,8 @@ instance FromYAML Info where parseYAML = YAML.withMap "info" \m -> do checkKeys m ["date", "sort", "updates", "show-updated", "unlisted", "gallery-title", "title", "artist", "nsfw-only", "tags", - "nsfw-tags", "desc", "nsfw-desc", "bg", "images", "thumb", - "links", "extras"] + "nsfw-tags", "exclude-tags", "desc", "nsfw-desc", "bg", + "images", "thumb", "links", "extras"] Info <$> m .: "date" <*> m .:? "sort" .!= "" <*> (m .:? "updates" >>= updateList) @@ -325,12 +331,13 @@ instance FromYAML Info where <*> m .: "title" <*> m .:? "gallery-title" <*> m .:? "artist" - <*> m .:? "nsfw-only" .!= False - <*> m .:? "tags" .!= [] - <*> m .:? "nsfw-tags" .!= [] - <*> m .:? "desc" .!= NoDesc - <*> m .:? "nsfw-desc" .!= NoDesc - <*> m .:? "bg" .!= Default + <*> m .:? "nsfw-only" .!= False + <*> m .:? "tags" .!= [] + <*> m .:? "nsfw-tags" .!= [] + <*> m .:? "exclude-tags" .!= [] + <*> m .:? "desc" .!= NoDesc + <*> m .:? "nsfw-desc" .!= NoDesc + <*> m .:? "bg" .!= Default <*> m .: "images" <*> m .:? "thumb" <*> m .:? "links" .!= [] @@ -517,6 +524,101 @@ instance FromYAML ArtistFilter where parseYAML = YAML.withStr "artist filter" readArtistFilter +data TagTransforms = + TagTransforms { + implies :: ![Implies], + replace :: !(HashMap Text Text), + replaceWarn :: !(HashMap Text Text), + warn :: ![Warning] + } deriving Show + +instance FromYAML TagTransforms where + parseYAML = YAML.withMap "tag transforms" \m -> do + checkKeys m ["implies", "replace", "replace-warn", "warn"] + TagTransforms <$> m .:? "implies" .!= [] + <*> m .:? "replace" .!= [] + <*> m .:? "replace-warn" .!= [] + <*> m .:? "warn" .!= [] + +emptyTransforms :: TagTransforms +emptyTransforms = TagTransforms [] [] [] [] + + +data SlashedRegex = SR Text Regex + +regex :: MonadFail m => Text -> m Regex +regex body = + let comp = Regex.defaultCompOpt {Regex.caseSensitive = False} + exec = Regex.defaultExecOpt in + Regex.makeRegexOptsM comp exec body + +withSR :: (Text -> Regex -> a) -> SlashedRegex -> a +withSR f (SR t r) = f t r + +instance FromYAML SlashedRegex where + parseYAML = YAML.withStr "string or regex" \str -> do + guard $ Text.length str > 2 && + Text.head str == '/' && + Text.last str == '/' + let body = Text.drop 1 $ Text.dropEnd 1 str + SR body <$> regex body + + +data Implies = RegexI Text Regex [Replacement] | LiteralI Text [Text] + +instance Show Implies where + showsPrec d (RegexI s _ rhss) = + showParen (d > 10) $ + showString "RegexI " . showsPrec 11 s . showString " _ " . + showsPrec 10 rhss + showsPrec d (LiteralI s rhss) = + showParen (d > 10) $ + showString "LiteralI " . showsPrec 11 s . showChar ' ' . + showsPrec 10 rhss + +instance FromYAML Implies where + parseYAML = withPairM \k v -> + withSR RegexI <$> parseYAML k <*> parseYAML v + <|> LiteralI <$> parseYAML k <*> parseYAML v + + +data Warning = RegexW Text Regex | LiteralW Text + +instance Show Warning where + showsPrec d (RegexW s _) = + showParen (d > 10) $ + showString "RegexI " . showsPrec 11 s . showString " _" + showsPrec d (LiteralW s) = + showParen (d > 10) $ + showString "LiteralI " . showsPrec 11 s + +instance FromYAML Warning where + parseYAML y = withSR RegexW <$> parseYAML y + <|> LiteralW <$> parseYAML y + + +data Replacement = Re Text [Either String Int] deriving Show + +parseReplacement :: MonadFail m => Text -> m Replacement +parseReplacement txt = + case ReadP.readP_to_S parser (Text.unpack txt) of + [(res, "")] -> pure $ Re txt res + _ -> fail $ + "parse error in replacement string \"" <> Text.unpack txt <> "\"" + where + parser = many (Left . pure <$> esc + <|> Left <$> lit + <|> Right . read <$> var) <* ReadP.eof + esc = ReadP.char '\\' *> ReadP.get + lit = ReadP.munch1 \c -> c /= '$' && c /= '\\' + var = bareVar <|> braceVar where + bareVar = ReadP.char '$' *> ReadP.munch1 Char.isDigit + braceVar = ReadP.string "${" *> ReadP.munch1 Char.isDigit <* ReadP.char '}' + +instance FromYAML Replacement where + parseYAML = YAML.withStr "regex replacement string" parseReplacement + + data IndexInfo = IndexInfo { title :: !Text, @@ -538,54 +640,6 @@ instance FromYAML IndexInfo where <*> m .:? "footer" <*> m .:? "tags" .!= emptyTransforms -data TagTransforms = - TagTransforms { - implies :: !(HashMap ImpliesKey [Text]), - replace :: !(HashMap Text Text), - replaceWarn :: !(HashMap Text Text), - warn :: !(HashSet Text) - } - deriving Show - -data ImpliesKey = RegexIK Text Regex | LiteralIK Text - -instance Eq ImpliesKey where - RegexIK s _ == RegexIK t _ = s == t - LiteralIK s == LiteralIK t = s == t - _ == _ = False - -instance Show ImpliesKey where - showsPrec d (RegexIK s _) = - showParen (d > 10) $ - showString "RegexIK " . showsPrec 11 s . showString " _" - showsPrec d (LiteralIK s) = - showParen (d > 10) $ showString "LiteralIK " . showsPrec 11 s - -instance Hashable ImpliesKey where - hashWithSalt s (RegexIK str _) = hashWithSalt s ('R', str) - hashWithSalt s (LiteralIK str) = hashWithSalt s ('L', str) - -emptyTransforms :: TagTransforms -emptyTransforms = TagTransforms [] [] [] [] - -instance FromYAML TagTransforms where - parseYAML = YAML.withMap "tag transforms" \m -> do - checkKeys m ["implies", "replace", "replace-warn", "warn"] - TagTransforms <$> m .:? "implies" .!= [] - <*> m .:? "replace" .!= [] - <*> m .:? "replace-warn" .!= [] - <*> m .:? "warn" .!= [] - -instance FromYAML ImpliesKey where - parseYAML = YAML.withStr "string or regex" \str -> pure - if Text.length str > 2 && - Text.head str == '/' && - Text.last str == '/' - then - let body = Text.drop 1 $ Text.dropEnd 1 str in - RegexIK body (Regex.makeRegex body) - else LiteralIK str - data Pair a b = Pair !a !b diff --git a/make-pages/ListTags.hs b/make-pages/ListTags.hs index dc7e117..dbf0774 100644 --- a/make-pages/ListTags.hs +++ b/make-pages/ListTags.hs @@ -2,12 +2,11 @@ module ListTags where import Info import Options (TagSort (..)) +import TagTransforms import Control.Monad import Data.Foldable -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (sort, sortBy) import Data.Ord (comparing) @@ -17,44 +16,62 @@ import Text.Printf (printf) type TagStats = HashMap Text Int type PathSet = HashSet FilePath +type FileWarnings = [(FilePath, TagWarning)] data Stats = Stats { tags :: TagStats, - untagged :: PathSet + untagged :: PathSet, + warns :: FileWarnings } instance Semigroup Stats where - Stats {tags = t1, untagged = u1} <> Stats {tags = t2, untagged = u2} = - Stats {tags = HashMap.unionWith (+) t1 t2, untagged = u1 <> u2} + s1 <> s2 = Stats { + tags = HashMap.unionWith (+) s1.tags s2.tags, + untagged = s1.untagged <> s2.untagged, + warns = s1.warns <> s2.warns + } instance Monoid Stats where - mempty = Stats {tags = [], untagged = []} + mempty = Stats {tags = [], untagged = [], warns = []} -stats1 :: Bool -> FilePath -> Info -> Stats -stats1 nsfw path (Info {tags, nsfwTags}) = - let tags' = if nsfw then tags <> nsfwTags else tags in - if null tags' then - Stats {tags = [], untagged = [path]} +stats1 :: TagTransforms -> Bool -> FilePath -> Info -> Stats +stats1 tt nsfw path (Info {tags, nsfwTags}) = + let startTags = if nsfw then tags <> nsfwTags else tags + TR outTags warns = applyTransforms tt startTags + in + if null outTags then + Stats {tags = [], untagged = [path], warns = map (path,) warns} else - let tagMap = HashMap.fromList $ map (, 1) $ HashSet.toList tags' in - Stats {tags = tagMap, untagged = []} + let tagMap = HashMap.fromList $ map (, 1) $ HashSet.toList outTags in + Stats {tags = tagMap, untagged = [], warns = map (path,) warns} -stats :: Bool -> [(FilePath, Info)] -> Stats -stats nsfw = foldMap $ uncurry $ stats1 nsfw +stats :: IndexInfo -> Bool -> [(FilePath, Info)] -> Stats +stats iinfo nsfw = foldMap $ uncurry $ stats1 iinfo.tags nsfw -run :: Bool -> Bool -> TagSort -> [(FilePath, Info)] -> IO () -run nsfw listUntagged ts infos = do - let Stats {tags, untagged} = stats nsfw infos +run :: IndexInfo + -> Bool -- ^ include nsfw? + -> Bool -- ^ list files with no tags + -> Bool -- ^ print tag warnings + -> TagSort + -> [(FilePath, Info)] -> + IO () +run iinfo nsfw listUntagged showWarnings ts infos = do + let Stats {tags, untagged, warns} = stats iinfo nsfw infos let sortedTags = sortBy (cmp ts) $ map swap $ HashMap.toList tags putStrLn "TAGS\n----" + printf "%5d: [total]\n" (length infos) for_ sortedTags \(count, path) -> - printf "%4d: %s\n" count path + printf "%5d: %s\n" count path when (listUntagged && not (null untagged)) $ do let sortedUntagged = sort $ HashSet.toList untagged putStrLn "\nUNTAGGED FILES\n--------------" for_ sortedUntagged $ printf " - %s\n" + when (showWarnings && not (null warns)) $ do + let hdr :: String = printf "WARNINGS (%d)" (length warns) + printf "\n%s\n%s\n" hdr (const '-' <$> hdr) + for_ warns \(file, warn) -> putStrLn $ showWarning file warn cmp :: TagSort -> (Int, Text) -> (Int, Text) -> Ordering cmp SortFreq = flip $ comparing fst diff --git a/make-pages/Main.hs b/make-pages/Main.hs index 959148f..2478c91 100644 --- a/make-pages/Main.hs +++ b/make-pages/Main.hs @@ -24,10 +24,12 @@ import qualified GalleryPage import qualified IndexPage import qualified RSS import qualified ListTags +import TagTransforms #ifdef PRETTY_VERBOSE import qualified Text.PrettyPrint as PP import qualified Text.Show.Pretty as PP +import Data.Function ((&)) #endif @@ -49,19 +51,20 @@ main = do main2 :: HasVerbose => ModeOptions -> IO () main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do - siteName <- (.title) <$> readYAML @IndexInfo index - info <- readYAML file + iinfo <- readYAML index + info <- transformInfoTags iinfo.tags <$> readYAML file printV $ "contents" := info let dir = takeDirectory $ makeRelative dataDir file - page <- SinglePage.make root siteName prefix nsfw dataDir dir info + page <- SinglePage.make root iinfo prefix nsfw dataDir dir info writeOutput output page main2 (GalleryPage {root, files, prefix, index, output, dataDir}) = do - (_, ginfo) <- galleryFromIndex index prefix + (iinfo, _, ginfo) <- galleryFromIndex index prefix printV $ "gallery_info" := ginfo - infos <- mapM (infoYAML dataDir) files + infos <- traverse (infoYAML dataDir) files + & fmap (fmap $ fmap $ transformInfoTags iinfo.tags) printV $ "infos" := infos - let page = GalleryPage.make root ginfo infos + let page = GalleryPage.make root iinfo ginfo infos writeOutput output page main2 (IndexPage {root, file, output}) = do @@ -71,9 +74,9 @@ main2 (IndexPage {root, file, output}) = do writeOutput output page main2 (RSS {files, root, index, prefix, output, dataDir}) = do - (name, ginfo) <- galleryFromIndex index prefix + (_, name, ginfo) <- galleryFromIndex index prefix printV $ "gallery_info" := ginfo - infos <- mapM (infoYAML dataDir) files + infos <- traverse (infoYAML dataDir) files printV $ "infos" := infos let output' = takeFileName <$> output let rss = RSS.make root name ginfo output' infos @@ -90,19 +93,24 @@ main2 (DependSingle {index, file, nsfw, output, prefix, buildDir, dataDir}) = do main2 (DependGallery {file, output, buildDir, dataDir, tmpDir, infoName}) = do IndexInfo {galleries} <- readYAML file printV $ "galleries" := galleries - infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName + infos <- findInfos dataDir infoName + >>= traverse (infoYAML dataDir) printV $ "info_files" := infos let dependGallery0 g = dependGallery' g file infos buildDir dataDir tmpDir let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $ map dependGallery0 galleries writeOutput output deps -main2 (ListTags {nsfw, listUntagged, dataDir, infoName, sortBy}) = do - infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName +main2 (ListTags {nsfw, listUntagged, showWarnings, index, + dataDir, infoName, sortBy}) = do + printV $ "index" := index + iinfo <- readYAML index + infos <- findInfos dataDir infoName >>= traverse (infoYAML dataDir) printV $ "info_files" := infos - ListTags.run nsfw listUntagged sortBy infos + ListTags.run iinfo nsfw listUntagged showWarnings sortBy infos +-- | applies tag transformations also infoYAML :: FilePath -- ^ data dir -> FilePath -- ^ yaml file -> IO (FilePath, Info) -- relative filename, contents @@ -118,10 +126,12 @@ findInfos dataDir infoName = readYAML :: YAML.FromYAML a => FilePath -> IO a readYAML file = ByteString.readFile file >>= decode1Must file -galleryFromIndex :: FilePath -> FilePath -> IO (Strict.Text, GalleryInfo) +galleryFromIndex :: FilePath -> FilePath -> + IO (IndexInfo, Strict.Text, GalleryInfo) galleryFromIndex file prefix = do - IndexInfo {title, galleries} <- readYAML file - maybe (fail $ "no gallery with prefix " ++ prefix) (pure . (title,)) $ + iinfo@(IndexInfo {title, galleries}) <- readYAML file + maybe (fail $ "no gallery with prefix " ++ prefix) + (pure . (iinfo, title,)) $ List.find (\g -> g.prefix == prefix) galleries decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a diff --git a/make-pages/Options.hs b/make-pages/Options.hs index 3b702e5..2f71367 100644 --- a/make-pages/Options.hs +++ b/make-pages/Options.hs @@ -61,8 +61,10 @@ data ModeOptions = | ListTags { dataDir :: FilePath, infoName :: FilePath, + index :: FilePath, nsfw :: Bool, listUntagged :: Bool, + showWarnings :: Bool, sortBy :: TagSort } deriving Show @@ -148,14 +150,17 @@ optionsParser = globalOpts `info` mainInfo where dgInfo = progDesc "generate makefile dependencies for a gallery" listTags = command "list-tags" $ ltOpts `info` ltInfo - ltOpts = ListTags <$> dataDir <*> infoName <*> nsfwT - <*> listUntagged_ <*> listSort + ltOpts = ListTags <$> dataDir <*> infoName <*> indexFile <*> nsfwT + <*> listUntagged <*> showWarnings <*> listSort nsfwT = switch $ short 'n' <> long "nsfw" <> help "include nsfw tags" - listUntagged_ = switch $ + listUntagged = switch $ short 'U' <> long "untagged" <> help "list files with no tags" + showWarnings = switch $ + short 'W' <> long "warnings" <> + help "show tag warnings" listSort = fmap toSort $ switch $ short 'a' <> long "alpha" <> help "sort alphabetically instead of by frequency" diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index f800f06..68d1615 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -4,21 +4,21 @@ module SinglePage (make) where import Date import Info import BuilderQQ -import qualified NsfwWarning +import NsfwWarning qualified +import TagTransforms import Control.Exception import Control.Monad +import Data.Char (isSpace) +import Data.Foldable +import Data.HashSet qualified as HashSet import Data.List (sort, intersperse) import Data.Maybe (fromMaybe, isJust) -import qualified Data.Text as Strict -import qualified Data.Text.Lazy as Lazy -import System.FilePath (joinPath, splitPath) -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.Traversable import Data.Semigroup -import Data.List.NonEmpty (toList) -import Data.Char (isSpace) +import Data.Text qualified as Strict +import Data.Text.Lazy qualified as Lazy +import Data.Traversable +import System.FilePath (joinPath, splitPath) -- | e.g. only nsfw images are present for a non-nsfw page @@ -32,22 +32,25 @@ instance Show NoEligibleImages where make :: Text -- ^ website root - -> Text -- ^ website name + -> IndexInfo -> FilePath -- ^ gallery prefix -> Bool -- ^ nsfw? -> FilePath -- ^ data dir -> FilePath -- ^ subdir of datadir containing this @info.yaml@ -> Info -> IO Lazy.Text -make root siteName prefix nsfw dataDir dir info = - toLazyText <$> make' root siteName prefix nsfw dataDir dir info +make root iinfo prefix nsfw dataDir dir info = + fmap toLazyText $ + make' root iinfo prefix nsfw dataDir dir $ + transformInfoTags iinfo.tags info -make' :: Text -> Text -> FilePath -> Bool -> FilePath -> FilePath -> Info +make' :: Text -> IndexInfo -> FilePath -> Bool -> FilePath -> FilePath -> Info -> IO Builder -make' root siteName prefix nsfw _dataDir dir +make' root iinfo prefix nsfw _dataDir dir info@(Info {date, title, artist, bg}) = do images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info let undir = joinPath (replicate (length (splitPath dir)) "..") + let siteName = iinfo.title let formattedDate = formatLong date @@ -59,7 +62,8 @@ make' root siteName prefix nsfw _dataDir dir let artistSection = makeArtist artist let descSection = makeDesc $ descFor nsfw info - let tagsList = makeTags undir $ tagsFor nsfw info + let tags = tagsFor nsfw info + let tagsList = makeTags undir tags let linksList = extLinks $ linksFor nsfw info let updates = sort $ updatesFor nsfw info let updatesList = makeUpdates updates diff --git a/make-pages/TagTransforms.hs b/make-pages/TagTransforms.hs new file mode 100644 index 0000000..01d36f5 --- /dev/null +++ b/make-pages/TagTransforms.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE RecordWildCards #-} +module TagTransforms + (TransformResult (..), + TagWarning (..), showWarning, printWarning, + matchWarning, applyImplies, applyTransforms1, applyTransforms, + transformInfoTags) +where + +import Info +import BuilderQQ qualified as Builder +import Control.Monad +import Data.Array (Array) +import Data.Array.Base ((!?)) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Text.Regex.TDFA qualified as Regex +import System.IO (hPutStrLn, stderr) +import Control.Applicative (Alternative(..), asum) +import Control.Monad.Writer + + +data TagWarning + = ReplaceWarn Text Text + | PresenceWarn Text + | UndefinedCapture Int Text + | ReplaceParseError Text + deriving Show + +data TransformResult = TR (HashSet Text) [TagWarning] + deriving Show + +instance Semigroup TransformResult where + TR t1 w1 <> TR t2 w2 = TR (t1 <> t2) (w1 <> w2) +instance Monoid TransformResult where + mempty = TR [] [] + +showWarning :: FilePath -> TagWarning -> String +showWarning file (ReplaceWarn from to) = + file ++ ": contains tag " ++ show from ++ + " (replacing with " ++ show to ++ ")" +showWarning file (PresenceWarn what) = + file ++ ": contains tag " ++ show what +showWarning file (UndefinedCapture i txt) = + file ++ ": replacement string " ++ show txt ++ + " contains undefined capture group $" ++ show i +showWarning file (ReplaceParseError txt) = + file ++ ": cannot parse replacement string " ++ show txt + +printWarning :: FilePath -> TagWarning -> IO () +printWarning f w = + hPutStrLn stderr $ "[WARN] " ++ showWarning f w + +matchWarning :: Text -> Warning -> Bool +matchWarning txt (RegexW _ rx) = Regex.match rx txt +matchWarning txt (LiteralW l) = l == txt + +applyImplies1 :: Array Int Text -> Replacement -> TransformResult +applyImplies1 subs (Re txt rhs) = + case traverse app rhs of + Left i -> TR [] [UndefinedCapture i txt] + Right oks -> TR [Builder.toStrictText $ mconcat oks] [] + where + app (Left str) = Right $ Builder.build str + app (Right i) = case subs !? i of + Just sub -> Right $ Builder.build sub + Nothing -> Left i + +applyImplies :: Text -> Implies -> Maybe TransformResult +applyImplies tag (RegexI _ rx outs) = + let res = Regex.mrSubs $ Regex.match rx tag in + if null res then empty else pure $ foldMap (applyImplies1 res) outs +applyImplies tag (LiteralI str outs) = + TR (HashSet.fromList outs) [] <$ guard (tag == str) + +ifJust :: Applicative m => Maybe a -> (a -> m ()) -> m Bool +ifJust m f = maybe (pure False) (\x -> True <$ f x) m + +applyTransforms1 :: TagTransforms -> Text -> TransformResult +applyTransforms1 t = execWriter . go where + go tag = do + replacedW <- ifJust (HashMap.lookup tag t.replaceWarn) \out -> do + tell $ TR [] [ReplaceWarn tag out] + go out + replaced <- ifJust (HashMap.lookup tag t.replace) go + unless (replacedW || replaced) do + tell $ TR [tag] [] + when (any (matchWarning tag) t.warn) do + tell $ TR [] [PresenceWarn tag] + forM_ (asum $ map (applyImplies tag) t.implies) \(TR tags ws) -> do + tell $ TR [] ws + forM_ tags go + +applyTransforms :: Foldable f => TagTransforms -> f Text -> TransformResult +applyTransforms t tags = foldMap (applyTransforms1 t) tags + +transformInfoTags :: TagTransforms -> Info -> Info +transformInfoTags t (Info {..}) = + let TR tags' _ = applyTransforms t tags + TR nsfwTags' _ = applyTransforms t nsfwTags in + Info { + tags = HashSet.difference tags' excludeTags, + nsfwTags = HashSet.difference nsfwTags' excludeTags, .. + } diff --git a/make-pages/make-pages.cabal b/make-pages/make-pages.cabal index e842fb2..3a3b5eb 100644 --- a/make-pages/make-pages.cabal +++ b/make-pages/make-pages.cabal @@ -17,6 +17,7 @@ executable make-pages BuilderQQ, Date, Info, + TagTransforms, Depend, NsfwWarning, GalleryPage, @@ -44,12 +45,14 @@ executable make-pages TemplateHaskell build-depends: base >= 4.16.4 && < 4.21, + array == 0.5.7.*, bytestring >= 0.11.3.1 && < 0.14, containers >= 0.6.0.1 && < 0.8, filemanip ^>= 0.3.6.3, filepath >= 1.4.2.1 && < 1.6, hashable >= 1.3.0.0 && < 1.5, HsYAML ^>= 0.2.1.0, + mtl == 2.3.1.*, optparse-applicative ^>= 0.15.1.0, process ^>= 1.6.8.2, regex-tdfa == 1.3.2.*,