From 9a54cc0d53caef660148f3613d8e2e3837d620c7 Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Mon, 16 Nov 2020 23:30:56 +0100 Subject: [PATCH] allow updates to be marked nsfw-only --- make-pages/GalleryPage.hs | 11 +++--- make-pages/Info.hs | 74 ++++++++++++++++++++++++++++++--------- make-pages/RSS.hs | 10 +++--- make-pages/SinglePage.hs | 26 ++++++++------ 4 files changed, 85 insertions(+), 36 deletions(-) diff --git a/make-pages/GalleryPage.hs b/make-pages/GalleryPage.hs index 0338bc7..a842cd5 100644 --- a/make-pages/GalleryPage.hs +++ b/make-pages/GalleryPage.hs @@ -11,7 +11,7 @@ import Data.Function (on, (&)) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.List (intersperse, groupBy, sortOn) +import Data.List (intersperse, groupBy, sortBy, sortOn) import qualified Data.Text.Lazy as Lazy import System.FilePath (takeDirectory, joinPath, splitPath) import GHC.Exts (Down (..), the) @@ -90,9 +90,10 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 infosByYear = [(the year, infopath) | infopath@(_, info) <- infos, - then sortOn by Down info, - let year = #latestYear info, + then sortInfo by info, + let year = #latestYear info nsfw, then group by Down year using groupBy'] + sortInfo f = sortBy $ flip (compareFor nsfw `on` f) groupBy' f = groupBy ((==) `on` f) undir = joinPath (replicate (length (splitPath prefix)) "..") @@ -159,8 +160,8 @@ makeItem nsfw file info@(Info {title, bg}) = [b|@0 thumb = getThumb dir info nsfw' = if nsfw && #anyNsfw info then [b| nsfw|] else "" tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info - date = #latestDate info + date = #latestDate info nsfw date' = formatShort date year' = #year date - updated' = if #updated info then [b|true|] else [b|false|] + updated' = if #updated info nsfw then [b|true|] else [b|false|] bgStyle = ifJust bg \col -> [b| style="background: $col"|] diff --git a/make-pages/Info.hs b/make-pages/Info.hs index ac2cef0..269237b 100644 --- a/make-pages/Info.hs +++ b/make-pages/Info.hs @@ -1,7 +1,8 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Info - (Info (..), tagsFor, descFor, imagesFor, linksFor, - Artist (..), Image (..), Link (..), + (Info (..), + tagsFor, descFor, imagesFor, linksFor, updatesFor, compareFor, sortFor, + Artist (..), Image (..), Link (..), Update (..), GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..), IndexInfo (..), readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, @@ -20,10 +21,9 @@ import Data.Foldable (find) import Data.Hashable (Hashable) import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (isJust, isNothing) -import Data.List (nub) +import Data.List (nub, sortBy) import Data.Ord (comparing) import Data.String (IsString) import Data.Text (Text) @@ -40,7 +40,7 @@ data Info = -- e.g. multiple things on the same day might have a,b,c in @sortEx@ to -- put them in the right order in the gallery sortEx :: !Text, - updates :: !(Map Date Text), + updates :: ![Update], -- | if false, don't show updated emblem even if @updates@ is non-empty showUpdated :: !Bool, title :: !Text, @@ -83,8 +83,17 @@ data Link = } deriving (Eq, Show) -instance HasField "sfw" Image Bool where getField = not . #nsfw -instance HasField "sfw" Link Bool where getField = not . #nsfw +data Update = + Update { + date :: !Date, + desc :: !Text, + nsfw :: !Bool + } + deriving (Eq, Ord, Show) + +instance HasField "sfw" Image Bool where getField = not . #nsfw +instance HasField "sfw" Link Bool where getField = not . #nsfw +instance HasField "sfw" Update Bool where getField = not . #nsfw instance HasField "sfwImages" Info [Image] where getField = filter #sfw . #images @@ -100,21 +109,28 @@ instance HasField "sfwLinks" Info [Link] where instance HasField "nsfwLinks" Info [Link] where getField = filter #nsfw . #links +instance HasField "sfwUpdates" Info [Update] where + getField = filter #sfw . #updates +instance HasField "nsfwUpdates" Info [Update] where + getField = filter #nsfw . #updates + instance HasField "thumb" Info (Maybe FilePath) where getField (Info {thumb', images}) = thumb' <|> #path <$> find #sfw images instance HasField "mine" Info Bool where getField = isNothing . #artist instance HasField "notMine" Info Bool where getField = isJust . #artist -instance HasField "latestDate" Info Date where - getField (Info {date, updates}) = maximum (date : Map.keys updates) +instance HasField "latestDate" Info (Bool -> Date) where + getField info@(Info {date}) nsfw = + maximum $ date : map #date (updatesFor nsfw info) -instance HasField "latestYear" Info Int where - getField = #year . #latestDate +instance HasField "latestYear" Info (Bool -> Int) where + getField info nsfw = #year $ #latestDate info nsfw -instance HasField "updated" Info Bool where - getField (Info {updates, showUpdated}) = showUpdated && not (Map.null updates) +instance HasField "updated" Info (Bool -> Bool) where + getField (Info {updates, showUpdated}) nsfw = showUpdated && updated + where updated = if nsfw then not $ null updates else any #sfw updates descFor :: Bool -> Info -> Maybe Text descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc) @@ -128,8 +144,14 @@ imagesFor nsfw = if nsfw then #images else #sfwImages linksFor :: Bool -> Info -> [Link] linksFor nsfw = if nsfw then #links else #sfwLinks -instance Ord Info where - compare = comparing \i -> (#latestDate i, #sortEx i, #title i) +updatesFor :: Bool -> Info -> [Update] +updatesFor nsfw = if nsfw then #updates else #sfwUpdates + +compareFor :: Bool -> Info -> Info -> Ordering +compareFor nsfw = comparing \i -> (#latestDate i nsfw, #sortEx i, #title i) + +sortFor :: Bool -> [Info] -> [Info] +sortFor = sortBy . compareFor newtype NoThumb = NoThumb FilePath @@ -158,7 +180,7 @@ instance FromYAML Info where parseYAML = YAML.withMap "info" \m -> Info <$> m .: "date" <*> m .:? "sort" .!= "" - <*> m .:? "updates" .!= [] + <*> (maybe [] getUL <$> m .:? "updates") <*> m .:? "show-updated" .!= True <*> m .: "title" <*> m .:? "artist" @@ -216,6 +238,23 @@ instance FromYAML Link where nsfw <- m .:? "nsfw" .!= False pure $ Link {title, url, nsfw} +newtype UpdateList = UL {getUL :: [Update]} + +instance FromYAML UpdateList where + parseYAML y = do + pairs <- YAML.withMap "updates" (pure . Map.toList) y + UL <$> traverse asEither pairs + where + asEither (date', rest) = do + date <- parseYAML date' + asDesc date rest <|> asObj date rest + asDesc date = YAML.withStr "desc" \desc -> + pure $ Update {date, desc, nsfw = False} + asObj date = YAML.withMap "update info" \m -> do + desc <- m .: "desc" + nsfw <- m .:? "nsfw" .!= False + pure $ Update {date, desc, nsfw} + data GalleryInfo = GalleryInfo { @@ -227,6 +266,9 @@ data GalleryInfo = } deriving (Eq, Show) +instance HasField "nsfw" GalleryInfo Bool where + getField g = #nsfw (#filters g) /= NoNsfw + data GalleryFilters = GalleryFilters { nsfw :: !NsfwFilter, diff --git a/make-pages/RSS.hs b/make-pages/RSS.hs index 61f95f4..4711826 100644 --- a/make-pages/RSS.hs +++ b/make-pages/RSS.hs @@ -5,9 +5,9 @@ import Info import BuilderQQ import Records () -import Data.List (sortOn) +import Data.List (sortBy) import Data.Maybe (isJust) -import Data.Ord (Down (..)) +import Data.Function (on) import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy import System.FilePath (takeDirectory) @@ -23,7 +23,7 @@ make root ginfo output infos = make' :: Strict.Text -> GalleryInfo -> Maybe FilePath -> [(FilePath, Info)] -> Builder -make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0 +make' root ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0 @@ -38,7 +38,9 @@ make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0 |] where link = [b|$root/$prefix|] - items = map (uncurry $ makeItem root prefix) $ sortOn (Down . #second) infos + nsfw = #nsfw ginfo + items = map (uncurry $ makeItem root prefix) $ + sortBy (flip (compareFor nsfw `on` #second)) infos selflink = case output of Nothing -> "" Just o -> [b||] diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index 5259b1f..9ad2d8d 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -7,7 +7,7 @@ import Records () import qualified NsfwWarning import Control.Exception -import qualified Data.Map.Strict as Map +import Data.List (sort) import Data.Maybe (fromMaybe) import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy @@ -36,8 +36,7 @@ make root prefix nsfw dataDir dir info = toLazyText <$> make' root prefix nsfw dataDir dir info make' :: Text -> FilePath -> Bool -> FilePath -> FilePath -> Info -> IO Builder -make' root prefix nsfw dataDir dir - info@(Info {date, title, artist, bg, updates}) = do +make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do images <- withSizes (dataDir dir) $ imagesFor nsfw info let undir = joinPath (replicate (length (splitPath dir)) "..") @@ -56,7 +55,8 @@ make' root prefix nsfw dataDir dir let descSection = makeDesc $ descFor nsfw info let tagsList = makeTags undir $ tagsFor nsfw info let linksList = extLinks $ linksFor nsfw info - let updatesList = makeUpdates $ Map.toList updates + let updates = sort $ updatesFor nsfw info + let updatesList = makeUpdates updates let makePrefetch (Image {path}) = [b||] let prefetches = map (makePrefetch . #first) $ tail images @@ -80,8 +80,9 @@ make' root prefix nsfw dataDir dir Nothing -> "by niss" let thumb = getThumb "" info - let updateDate = ifJust (Map.lookupMax updates) \(formatLong -> u, _) -> - [b|
updated $u|] + let updateDate = ifJust (last' updates) \(Update {date = d}) -> + let updated = formatLong d in + [b|
updated $updated|] let nsfwScript = NsfwWarning.script nsfw let nsfwDialog = NsfwWarning.dialog nsfw @@ -153,6 +154,9 @@ make' root prefix nsfw dataDir dir |] +last' :: [a] -> Maybe a +last' xs = if null xs then Nothing else Just $ last xs + makeArtist :: Artist -> Builder makeArtist (Artist {name, url}) = [b|

by $artistLink

|] @@ -236,7 +240,7 @@ extLink (Link {title, url}) = [b|@8 |] -makeUpdates :: [(Date, Text)] -> Builder +makeUpdates :: [Update] -> Builder makeUpdates ups = if null ups then "" else [b|@4
@@ -246,12 +250,12 @@ makeUpdates ups =
|] - where updateList = map (uncurry makeUpdate) ups + where updateList = map makeUpdate ups -makeUpdate :: Date -> Text -> Builder -makeUpdate date txt = [b|@8 +makeUpdate :: Update -> Builder +makeUpdate (Update {date, desc}) = [b|@8
$date' -
$txt +
$desc |] where date' = formatSlash date