allow updates to be marked nsfw-only

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,
+      then sortInfo by info,
-      let year = #latestYear 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"|]

make-pages/Info.hs

@@ -1,7 +1,8 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 module Info
-  (Info (..), tagsFor, descFor, imagesFor, linksFor,
+  (Info (..),
-   Artist (..), Image (..), Link (..),
+   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
+data Update =
-instance HasField "sfw"  Link  Bool where getField = not . #nsfw
+  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
+instance HasField "latestDate" Info (Bool -> Date) where
-  getField (Info {date, updates}) = maximum (date : Map.keys updates)
+  getField info@(Info {date}) nsfw =
+    maximum $ date : map #date (updatesFor nsfw info)
 
-instance HasField "latestYear" Info Int where
+instance HasField "latestYear" Info (Bool -> Int) where
-  getField = #year . #latestDate
+  getField info nsfw = #year $ #latestDate info nsfw
 
 
-instance HasField "updated" Info Bool where
+instance HasField "updated" Info (Bool -> Bool) where
-  getField (Info {updates, showUpdated}) = showUpdated && not (Map.null updates)
+  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
+updatesFor :: Bool -> Info -> [Update]
-  compare = comparing \i -> (#latestDate i, #sortEx i, #title i)
+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,

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
     <?xml version="1.0" encoding="UTF-8"?>
     <rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom">
       <channel>
@@ -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|<atom:link href="$link/$o" rel="self" />|]

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
+make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
-      info@(Info {date, title, artist, bg, updates}) = 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|<link rel=prefetch href=$path>|]
   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, _) ->
+  let updateDate = ifJust (last' updates) \(Update {date = d}) ->
-        [b|<br> <span class=updated>updated $u</span>|]
+        let updated = formatLong d in
+        [b|<br> <span class=updated>updated $updated</span>|]
 
   let nsfwScript = NsfwWarning.script nsfw
   let nsfwDialog = NsfwWarning.dialog nsfw
@@ -153,6 +154,9 @@ make' root prefix nsfw dataDir dir
     </template>
   |]
 
+last' :: [a] -> Maybe a
+last' xs = if null xs then Nothing else Just $ last xs
+
 makeArtist :: Artist -> Builder
 makeArtist (Artist {name, url}) =
   [b|<h2 id=artist class="left corner">by $artistLink</h2>|]
@@ -236,7 +240,7 @@ extLink (Link {title, url}) = [b|@8
       </a>
   |]
 
-makeUpdates :: [(Date, Text)] -> Builder
+makeUpdates :: [Update] -> Builder
 makeUpdates ups =
   if null ups then "" else [b|@4
     <section id=updates class=info-section>
@@ -246,12 +250,12 @@ makeUpdates ups =
       </dl>
     </section>
   |]
-  where updateList = map (uncurry makeUpdate) ups
+ where updateList = map makeUpdate ups
 
-makeUpdate :: Date -> Text -> Builder
+makeUpdate :: Update -> Builder
-makeUpdate date txt = [b|@8
+makeUpdate (Update {date, desc}) = [b|@8
     <dt>$date'
-    <dd>$txt
+    <dd>$desc
   |]
   where date' = formatSlash date