allow updates to be marked nsfw-only
This commit is contained in:
parent
6567bdf059
commit
9a54cc0d53
4 changed files with 85 additions and 36 deletions
|
|
@ -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"|]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
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,
|
||||
|
|
|
|||
|
|
@ -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" />|]
|
||||
|
|
|
|||
|
|
@ -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|<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, _) ->
|
||||
[b|<br> <span class=updated>updated $u</span>|]
|
||||
let updateDate = ifJust (last' updates) \(Update {date = d}) ->
|
||||
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 date txt = [b|@8
|
||||
makeUpdate :: Update -> Builder
|
||||
makeUpdate (Update {date, desc}) = [b|@8
|
||||
<dt>$date'
|
||||
<dd>$txt
|
||||
<dd>$desc
|
||||
|]
|
||||
where date' = formatSlash date
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue