rhi/gallery
1
0
Fork 0
Code Issues 5 Pull requests 1 Releases Wiki Activity

implement tag aliases, replacements, warnings

Browse source 
warnings are printed by `list-tags`
This commit is contained in:
rhiannon morris 2024-11-05 00:21:35 +01:00
parent cae6400ec9
commit 67f0c3ded7
9 changed files with 319 additions and 118 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
Makefile
View file

@ -5,6 +5,7 @@ TMPDIR := _tmp
BUILDDIR := _build BUILDDIR := _build
INFONAME := info.yaml INFONAME := info.yaml
ROOT := https://gallery.niss.website ROOT := https://gallery.niss.website
INDEX := $(DATADIR)/index.yaml
# SMALL = thumbnails, MED = single pages (link to full size) # SMALL = thumbnails, MED = single pages (link to full size)
SMALL := 200 SMALL := 200
@ -28,7 +29,7 @@ BSCRIPTS = $(patsubst %.ts,$(BUILDDIR)/%.js,$(TSCRIPTS))
all: build all: build
build: $(BUILDDIR)/index.html $(BSTATIC) $(BSCRIPTS) build: $(BUILDDIR)/index.html $(BSTATIC) $(BSCRIPTS)
$(BUILDDIR)/index.html: $(DATADIR)/index.yaml $(MAKEPAGES) $(BUILDDIR)/index.html: $(INDEX) $(MAKEPAGES)
echo "[index] "$@ echo "[index] "$@
mkdir -p $(dir $@) mkdir -p $(dir $@)
$(MAKEPAGES) $(MPFLAGS) index --root $(ROOT) $< --output $@ $(MAKEPAGES) $(MPFLAGS) index --root $(ROOT) $< --output $@
@ -85,7 +86,7 @@ $(MAKEPAGES): make-pages/*.hs make-pages/make-pages.cabal
-exec cp {} $@ \; -exec cp {} $@ \;
$(TMPDIR)/index.mk: $(DATADIR)/index.yaml $(YAMLS) $(MAKEPAGES) $(TMPDIR)/index.mk: $(INDEX) $(YAMLS) $(MAKEPAGES)
$(call depend-gallery) $(call depend-gallery)
NODEPS := mostlyclean clean distclean list-tags NODEPS := mostlyclean clean distclean list-tags
@ -109,7 +110,7 @@ distclean: clean
.PHONY: list-tags .PHONY: list-tags
list-tags: $(MAKEPAGES) list-tags: $(MAKEPAGES)
$(MAKEPAGES) list-tags --untagged --nsfw $(MAKEPAGES) list-tags --untagged --warnings --nsfw --index $(INDEX)
HOST ?= gallery.niss.website HOST ?= gallery.niss.website

12
make-pages/GalleryPage.hs
View file

@ -1,15 +1,16 @@
{-# LANGUAGE RecordWildCards #-}
module GalleryPage (make) where module GalleryPage (make) where
import BuilderQQ import BuilderQQ
import Date import Date
import Info import Info
import qualified NsfwWarning import qualified NsfwWarning
import TagTransforms
import Control.Monad import Control.Monad
import Data.Foldable import Data.Foldable
import Data.Function ((&)) import Data.Function ((&))
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.List (intersperse, sort, sortOn) import Data.List (intersperse, sort, sortOn)
import Data.Maybe import Data.Maybe
@ -17,12 +18,15 @@ import Data.Ord (Down (..))
import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy as Lazy
import System.FilePath (takeDirectory, joinPath, splitPath) import System.FilePath (takeDirectory, joinPath, splitPath)
make :: Text -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text make :: Text -> IndexInfo -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text
make root ginfo infos = toLazyText $ make' root ginfo infos make root iinfo ginfo infos =
toLazyText $ make' root ginfo $
map (fmap $ transformInfoTags iinfo.tags) infos
make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder 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|
<!DOCTYPE html> <!DOCTYPE html>
<html lang=en> <html lang=en>
<meta charset=utf-8> <meta charset=utf-8>

160
make-pages/Info.hs
View file

@ -1,6 +1,5 @@
{-# OPTIONS_GHC -fdefer-typed-holes #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE PatternSynonyms #-}
module Info module Info
(Info (..), (Info (..),
anySfw, anyNsfw, allSfw, allNsfw, anySfw, anyNsfw, allSfw, allNsfw,
@ -20,18 +19,23 @@ module Info
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..), GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
TagTransforms (..), emptyTransforms,
Implies (..), Replacement (..), Warning (..),
IndexInfo (..), IndexInfo (..),
NoThumb (..), getThumb, thumbFile, pageFile, bigFile, NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
-- ** Reexports -- ** Reexports
Date (..), Day (..), Text, NonEmpty (..)) Date (..), Day (..), Text, NonEmpty (..), Regex, HashSet, HashMap)
where where
import Date import Date
import Control.Applicative import Control.Applicative
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Data.Bitraversable (bitraverse) import Data.Bitraversable (bitraverse)
import Data.Char qualified as Char
import Data.Foldable (find) import Data.Foldable (find)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
@ -53,6 +57,7 @@ import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import Data.YAML qualified as YAML import Data.YAML qualified as YAML
import GHC.Records import GHC.Records
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension) import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
import Text.ParserCombinators.ReadP qualified as ReadP
import Text.Regex.TDFA (Regex) import Text.Regex.TDFA (Regex)
import Text.Regex.TDFA qualified as Regex import Text.Regex.TDFA qualified as Regex
@ -75,6 +80,7 @@ data Info =
nsfwOnly :: !Bool, nsfwOnly :: !Bool,
tags :: !(HashSet Text), tags :: !(HashSet Text),
nsfwTags :: !(HashSet Text), nsfwTags :: !(HashSet Text),
excludeTags :: !(HashSet Text), -- remove tags that would be implied
desc :: !Desc, desc :: !Desc,
nsfwDesc :: !Desc, nsfwDesc :: !Desc,
bg :: !Bg, bg :: !Bg,
@ -315,8 +321,8 @@ instance FromYAML Info where
parseYAML = YAML.withMap "info" \m -> do parseYAML = YAML.withMap "info" \m -> do
checkKeys m ["date", "sort", "updates", "show-updated", "unlisted", checkKeys m ["date", "sort", "updates", "show-updated", "unlisted",
"gallery-title", "title", "artist", "nsfw-only", "tags", "gallery-title", "title", "artist", "nsfw-only", "tags",
"nsfw-tags", "desc", "nsfw-desc", "bg", "images", "thumb", "nsfw-tags", "exclude-tags", "desc", "nsfw-desc", "bg",
"links", "extras"] "images", "thumb", "links", "extras"]
Info <$> m .: "date" Info <$> m .: "date"
<*> m .:? "sort" .!= "" <*> m .:? "sort" .!= ""
<*> (m .:? "updates" >>= updateList) <*> (m .:? "updates" >>= updateList)
@ -328,6 +334,7 @@ instance FromYAML Info where
<*> m .:? "nsfw-only" .!= False <*> m .:? "nsfw-only" .!= False
<*> m .:? "tags" .!= [] <*> m .:? "tags" .!= []
<*> m .:? "nsfw-tags" .!= [] <*> m .:? "nsfw-tags" .!= []
<*> m .:? "exclude-tags" .!= []
<*> m .:? "desc" .!= NoDesc <*> m .:? "desc" .!= NoDesc
<*> m .:? "nsfw-desc" .!= NoDesc <*> m .:? "nsfw-desc" .!= NoDesc
<*> m .:? "bg" .!= Default <*> m .:? "bg" .!= Default
@ -517,6 +524,101 @@ instance FromYAML ArtistFilter where
parseYAML = YAML.withStr "artist filter" readArtistFilter 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 = data IndexInfo =
IndexInfo { IndexInfo {
title :: !Text, title :: !Text,
@ -538,54 +640,6 @@ instance FromYAML IndexInfo where
<*> m .:? "footer" <*> m .:? "footer"
<*> m .:? "tags" .!= emptyTransforms <*> 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 data Pair a b = Pair !a !b

55
make-pages/ListTags.hs
View file

@ -2,12 +2,11 @@ module ListTags where
import Info import Info
import Options (TagSort (..)) import Options (TagSort (..))
import TagTransforms
import Control.Monad import Control.Monad
import Data.Foldable import Data.Foldable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.List (sort, sortBy) import Data.List (sort, sortBy)
import Data.Ord (comparing) import Data.Ord (comparing)
@ -17,44 +16,62 @@ import Text.Printf (printf)
type TagStats = HashMap Text Int type TagStats = HashMap Text Int
type PathSet = HashSet FilePath type PathSet = HashSet FilePath
type FileWarnings = [(FilePath, TagWarning)]
data Stats = data Stats =
Stats { Stats {
tags :: TagStats, tags :: TagStats,
untagged :: PathSet untagged :: PathSet,
warns :: FileWarnings
} }
instance Semigroup Stats where instance Semigroup Stats where
Stats {tags = t1, untagged = u1} <> Stats {tags = t2, untagged = u2} = s1 <> s2 = Stats {
Stats {tags = HashMap.unionWith (+) t1 t2, untagged = u1 <> u2} tags = HashMap.unionWith (+) s1.tags s2.tags,
untagged = s1.untagged <> s2.untagged,
warns = s1.warns <> s2.warns
}
instance Monoid Stats where instance Monoid Stats where
mempty = Stats {tags = [], untagged = []} mempty = Stats {tags = [], untagged = [], warns = []}
stats1 :: Bool -> FilePath -> Info -> Stats stats1 :: TagTransforms -> Bool -> FilePath -> Info -> Stats
stats1 nsfw path (Info {tags, nsfwTags}) = stats1 tt nsfw path (Info {tags, nsfwTags}) =
let tags' = if nsfw then tags <> nsfwTags else tags in let startTags = if nsfw then tags <> nsfwTags else tags
if null tags' then TR outTags warns = applyTransforms tt startTags
Stats {tags = [], untagged = [path]} in
if null outTags then
Stats {tags = [], untagged = [path], warns = map (path,) warns}
else else
let tagMap = HashMap.fromList $ map (, 1) $ HashSet.toList tags' in let tagMap = HashMap.fromList $ map (, 1) $ HashSet.toList outTags in
Stats {tags = tagMap, untagged = []} Stats {tags = tagMap, untagged = [], warns = map (path,) warns}
stats :: Bool -> [(FilePath, Info)] -> Stats stats :: IndexInfo -> Bool -> [(FilePath, Info)] -> Stats
stats nsfw = foldMap $ uncurry $ stats1 nsfw stats iinfo nsfw = foldMap $ uncurry $ stats1 iinfo.tags nsfw
run :: Bool -> Bool -> TagSort -> [(FilePath, Info)] -> IO () run :: IndexInfo
run nsfw listUntagged ts infos = do -> Bool -- ^ include nsfw?
let Stats {tags, untagged} = stats nsfw infos -> 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 let sortedTags = sortBy (cmp ts) $ map swap $ HashMap.toList tags
putStrLn "TAGS\n----" putStrLn "TAGS\n----"
printf "%5d: [total]\n" (length infos)
for_ sortedTags \(count, path) -> for_ sortedTags \(count, path) ->
printf "%4d: %s\n" count path printf "%5d: %s\n" count path
when (listUntagged && not (null untagged)) $ do when (listUntagged && not (null untagged)) $ do
let sortedUntagged = sort $ HashSet.toList untagged let sortedUntagged = sort $ HashSet.toList untagged
putStrLn "\nUNTAGGED FILES\n--------------" putStrLn "\nUNTAGGED FILES\n--------------"
for_ sortedUntagged $ printf " - %s\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 :: TagSort -> (Int, Text) -> (Int, Text) -> Ordering
cmp SortFreq = flip $ comparing fst cmp SortFreq = flip $ comparing fst

40
make-pages/Main.hs
View file

@ -24,10 +24,12 @@ import qualified GalleryPage
import qualified IndexPage import qualified IndexPage
import qualified RSS import qualified RSS
import qualified ListTags import qualified ListTags
import TagTransforms
#ifdef PRETTY_VERBOSE #ifdef PRETTY_VERBOSE
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import qualified Text.Show.Pretty as PP import qualified Text.Show.Pretty as PP
import Data.Function ((&))
#endif #endif
@ -49,19 +51,20 @@ main = do
main2 :: HasVerbose => ModeOptions -> IO () main2 :: HasVerbose => ModeOptions -> IO ()
main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do
siteName <- (.title) <$> readYAML @IndexInfo index iinfo <- readYAML index
info <- readYAML file info <- transformInfoTags iinfo.tags <$> readYAML file
printV $ "contents" := info printV $ "contents" := info
let dir = takeDirectory $ makeRelative dataDir file 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 writeOutput output page
main2 (GalleryPage {root, files, prefix, index, output, dataDir}) = do main2 (GalleryPage {root, files, prefix, index, output, dataDir}) = do
(_, ginfo) <- galleryFromIndex index prefix (iinfo, _, ginfo) <- galleryFromIndex index prefix
printV $ "gallery_info" := ginfo printV $ "gallery_info" := ginfo
infos <- mapM (infoYAML dataDir) files infos <- traverse (infoYAML dataDir) files
& fmap (fmap $ fmap $ transformInfoTags iinfo.tags)
printV $ "infos" := infos printV $ "infos" := infos
let page = GalleryPage.make root ginfo infos let page = GalleryPage.make root iinfo ginfo infos
writeOutput output page writeOutput output page
main2 (IndexPage {root, file, output}) = do main2 (IndexPage {root, file, output}) = do
@ -71,9 +74,9 @@ main2 (IndexPage {root, file, output}) = do
writeOutput output page writeOutput output page
main2 (RSS {files, root, index, prefix, output, dataDir}) = do main2 (RSS {files, root, index, prefix, output, dataDir}) = do
(name, ginfo) <- galleryFromIndex index prefix (_, name, ginfo) <- galleryFromIndex index prefix
printV $ "gallery_info" := ginfo printV $ "gallery_info" := ginfo
infos <- mapM (infoYAML dataDir) files infos <- traverse (infoYAML dataDir) files
printV $ "infos" := infos printV $ "infos" := infos
let output' = takeFileName <$> output let output' = takeFileName <$> output
let rss = RSS.make root name ginfo output' infos 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 main2 (DependGallery {file, output, buildDir, dataDir, tmpDir, infoName}) = do
IndexInfo {galleries} <- readYAML file IndexInfo {galleries} <- readYAML file
printV $ "galleries" := galleries printV $ "galleries" := galleries
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName infos <- findInfos dataDir infoName
>>= traverse (infoYAML dataDir)
printV $ "info_files" := infos printV $ "info_files" := infos
let dependGallery0 g = dependGallery' g file infos buildDir dataDir tmpDir let dependGallery0 g = dependGallery' g file infos buildDir dataDir tmpDir
let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $ let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $
map dependGallery0 galleries map dependGallery0 galleries
writeOutput output deps writeOutput output deps
main2 (ListTags {nsfw, listUntagged, dataDir, infoName, sortBy}) = do main2 (ListTags {nsfw, listUntagged, showWarnings, index,
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName dataDir, infoName, sortBy}) = do
printV $ "index" := index
iinfo <- readYAML index
infos <- findInfos dataDir infoName >>= traverse (infoYAML dataDir)
printV $ "info_files" := infos 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 infoYAML :: FilePath -- ^ data dir
-> FilePath -- ^ yaml file -> FilePath -- ^ yaml file
-> IO (FilePath, Info) -- relative filename, contents -> IO (FilePath, Info) -- relative filename, contents
@ -118,10 +126,12 @@ findInfos dataDir infoName =
readYAML :: YAML.FromYAML a => FilePath -> IO a readYAML :: YAML.FromYAML a => FilePath -> IO a
readYAML file = ByteString.readFile file >>= decode1Must file 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 galleryFromIndex file prefix = do
IndexInfo {title, galleries} <- readYAML file iinfo@(IndexInfo {title, galleries}) <- readYAML file
maybe (fail $ "no gallery with prefix " ++ prefix) (pure . (title,)) $ maybe (fail $ "no gallery with prefix " ++ prefix)
(pure . (iinfo, title,)) $
List.find (\g -> g.prefix == prefix) galleries List.find (\g -> g.prefix == prefix) galleries
decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a

11
make-pages/Options.hs
View file

@ -61,8 +61,10 @@ data ModeOptions =
| ListTags { | ListTags {
dataDir :: FilePath, dataDir :: FilePath,
infoName :: FilePath, infoName :: FilePath,
index :: FilePath,
nsfw :: Bool, nsfw :: Bool,
listUntagged :: Bool, listUntagged :: Bool,
showWarnings :: Bool,
sortBy :: TagSort sortBy :: TagSort
} }
deriving Show deriving Show
@ -148,14 +150,17 @@ optionsParser = globalOpts `info` mainInfo where
dgInfo = progDesc "generate makefile dependencies for a gallery" dgInfo = progDesc "generate makefile dependencies for a gallery"
listTags = command "list-tags" $ ltOpts `info` ltInfo listTags = command "list-tags" $ ltOpts `info` ltInfo
ltOpts = ListTags <$> dataDir <*> infoName <*> nsfwT ltOpts = ListTags <$> dataDir <*> infoName <*> indexFile <*> nsfwT
<*> listUntagged_ <*> listSort <*> listUntagged <*> showWarnings <*> listSort
nsfwT = switch $ nsfwT = switch $
short 'n' <> long "nsfw" <> short 'n' <> long "nsfw" <>
help "include nsfw tags" help "include nsfw tags"
listUntagged_ = switch $ listUntagged = switch $
short 'U' <> long "untagged" <> short 'U' <> long "untagged" <>
help "list files with no tags" help "list files with no tags"
showWarnings = switch $
short 'W' <> long "warnings" <>
help "show tag warnings"
listSort = fmap toSort $ switch $ listSort = fmap toSort $ switch $
short 'a' <> long "alpha" <> short 'a' <> long "alpha" <>
help "sort alphabetically instead of by frequency" help "sort alphabetically instead of by frequency"

34
make-pages/SinglePage.hs
View file

@ -4,21 +4,21 @@ module SinglePage (make) where
import Date import Date
import Info import Info
import BuilderQQ import BuilderQQ
import qualified NsfwWarning import NsfwWarning qualified
import TagTransforms
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Data.Char (isSpace)
import Data.Foldable
import Data.HashSet qualified as HashSet
import Data.List (sort, intersperse) import Data.List (sort, intersperse)
import Data.Maybe (fromMaybe, isJust) 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.Semigroup
import Data.List.NonEmpty (toList) import Data.Text qualified as Strict
import Data.Char (isSpace) 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 -- | e.g. only nsfw images are present for a non-nsfw page
@ -32,22 +32,25 @@ instance Show NoEligibleImages where
make :: Text -- ^ website root make :: Text -- ^ website root
-> Text -- ^ website name -> IndexInfo
-> FilePath -- ^ gallery prefix -> FilePath -- ^ gallery prefix
-> Bool -- ^ nsfw? -> Bool -- ^ nsfw?
-> FilePath -- ^ data dir -> FilePath -- ^ data dir
-> FilePath -- ^ subdir of datadir containing this @info.yaml@ -> FilePath -- ^ subdir of datadir containing this @info.yaml@
-> Info -> IO Lazy.Text -> Info -> IO Lazy.Text
make root siteName prefix nsfw dataDir dir info = make root iinfo prefix nsfw dataDir dir info =
toLazyText <$> make' root siteName 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 -> IO Builder
make' root siteName prefix nsfw _dataDir dir make' root iinfo prefix nsfw _dataDir dir
info@(Info {date, title, artist, bg}) = do info@(Info {date, title, artist, bg}) = do
images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info
let undir = joinPath (replicate (length (splitPath dir)) "..") let undir = joinPath (replicate (length (splitPath dir)) "..")
let siteName = iinfo.title
let formattedDate = formatLong date let formattedDate = formatLong date
@ -59,7 +62,8 @@ make' root siteName prefix nsfw _dataDir dir
let artistSection = makeArtist artist let artistSection = makeArtist artist
let descSection = makeDesc $ descFor nsfw info 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 linksList = extLinks $ linksFor nsfw info
let updates = sort $ updatesFor nsfw info let updates = sort $ updatesFor nsfw info
let updatesList = makeUpdates updates let updatesList = makeUpdates updates

103
make-pages/TagTransforms.hs Normal file
View file

@ -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, ..
}

3
make-pages/make-pages.cabal
View file

@ -17,6 +17,7 @@ executable make-pages
BuilderQQ, BuilderQQ,
Date, Date,
Info, Info,
TagTransforms,
Depend, Depend,
NsfwWarning, NsfwWarning,
GalleryPage, GalleryPage,
@ -44,12 +45,14 @@ executable make-pages
TemplateHaskell TemplateHaskell
build-depends: build-depends:
base >= 4.16.4 && < 4.21, base >= 4.16.4 && < 4.21,
array == 0.5.7.*,
bytestring >= 0.11.3.1 && < 0.14, bytestring >= 0.11.3.1 && < 0.14,
containers >= 0.6.0.1 && < 0.8, containers >= 0.6.0.1 && < 0.8,
filemanip ^>= 0.3.6.3, filemanip ^>= 0.3.6.3,
filepath >= 1.4.2.1 && < 1.6, filepath >= 1.4.2.1 && < 1.6,
hashable >= 1.3.0.0 && < 1.5, hashable >= 1.3.0.0 && < 1.5,
HsYAML ^>= 0.2.1.0, HsYAML ^>= 0.2.1.0,
mtl == 2.3.1.*,
optparse-applicative ^>= 0.15.1.0, optparse-applicative ^>= 0.15.1.0,
process ^>= 1.6.8.2, process ^>= 1.6.8.2,
regex-tdfa == 1.3.2.*, regex-tdfa == 1.3.2.*,