gallery/make-pages/SinglePage.hs

354 lines
9.6 KiB
Haskell

module SinglePage (make) where
import Date
import Info
import BuilderQQ
import Records ()
import qualified NsfwWarning
import Control.Exception
import Control.Monad
import Data.List (sort, intersperse)
import Data.Maybe (fromMaybe, isNothing, isJust)
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import System.FilePath (joinPath, splitPath)
import qualified Data.HashSet as Set
import Data.Traversable
-- | e.g. only nsfw images are present for a non-nsfw page
newtype NoEligibleImages = NoEligibleImages {title :: Strict.Text}
deriving stock Eq deriving anyclass Exception
instance Show NoEligibleImages where
show (NoEligibleImages {title}) =
Strict.unpack title <> ": no images selected\n" <>
" (probably a nsfw-only work without --nsfw set)"
make :: Text -- ^ website root
-> Text -- ^ website name
-> 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' :: Text -> Text -> FilePath -> Bool -> FilePath -> FilePath -> Info
-> IO Builder
make' root siteName prefix nsfw _dataDir dir
info@(Info {date, title, artist, bg}) = do
let images = imagesFor nsfw info
let undir = joinPath (replicate (length (splitPath dir)) "..")
let formattedDate = formatLong date
let buttonBar = makeButtonBar title $ addIds images
let allImages = #all images
let image0@(Image {path = path0, download = download0'}) = head allImages
let otherImages = tail allImages
let download0 = fromMaybe (bigFile path0) download0'
let path0' = pageFile path0
let artistSection = makeArtist artist
let descSection = makeDesc $ descFor nsfw info
let tagsList = makeTags undir $ tagsFor nsfw info
let linksList = extLinks $ linksFor nsfw info
let updates = sort $ updatesFor nsfw info
let updatesList = makeUpdates updates
let makePrefetch (Image {path}) = [b|<link rel=prefetch href=$path'>|]
where path' = bigFile path
let prefetches = map makePrefetch otherImages
let makeWarning w = [b|@0
<figcaption id=cw aria-role=button tabindex=0>
<span id=cw-text>$w</span>
</figcaption>
|]
let defWarning = [b|
i forgot to add a cw, sorry! <br>
if you can let me know i'd appreciate it
|]
let warning'
| Just w <- #warning image0 = makeWarning w
| #nsfw image0 = makeWarning defWarning
| otherwise = mempty
let warningT = makeWarning [b|.|]
let bgStyle = case bg of
Default -> ""
NoBorder -> [b|@0
<style>
#mainfig {
background: transparent;
border: none;
box-shadow: none;
}
</style>
|]
Other col -> [b|@0
<style> #mainfig { background: $col; } </style>
|]
let url = [b|$root/$prefix/$dir|]
let desc = case artist of
Just (Artist {name}) -> [b|by $name|]
Nothing -> "by niss"
let thumb = getThumb "" info
let updateDate = ifJust (last' updates) \(d, _) ->
let updated = formatLong d in
[b|<br> <span class=updated>updated $updated</span>|]
let nsfw' = NsfwWarning.Single <$ guard nsfw
let nsfwScript = NsfwWarning.script nsfw'
let nsfwDialog = NsfwWarning.dialog nsfw'
let imageMeta =
if #sfw image0 && isNothing (#warning image0) then [b|@0
<meta property=og:image content="$url/$path0'">
<meta name=twitter:card content=summary_large_image>
<meta name=twitter:image content="$url/$path0'">
|] else [b|@0
<meta property=og:image content="$url/$thumb">
<meta name=twitter:card content=summary>
|]
pure [b|@0
<!DOCTYPE html>
<html lang=en>
<meta charset=utf-8>
<meta name=viewport content="width=1200,viewport-fit=cover">
<link rel=stylesheet href=/style/shiny/single.css>
<link rel=icon href=/style/niss.svg>
<meta property=og:type content=article>
<meta property=og:title content="$title">
<meta property=og:site_name content="$siteName">
<meta property=og:description content="$desc">
<meta property=og:url content="$url">
$imageMeta
<meta name=robots content='noai,noimageai'>
<script src=/script/single.js type=module></script>
$nsfwScript
$bgStyle
$0.prefetches
<title>$title</title>
$nsfwDialog
<div class=page>
<header>
<h1>$title</h1>
<h2 id=date class="right corner">
$formattedDate $updateDate
</h2>
<h2 class="left corner">
<a href=$undir>back to gallery</a>
</h2>
</header>
$2.buttonBar
<main>
<figure id=mainfig>
$warning'
<a id=mainlink href="$download0" title="download full version">
<img id=mainimg src="$path0'" alt="">
</a>
</figure>
<div id=info>
$6.artistSection
$6.descSection
$6.updatesList
$6.linksList
$6.tagsList
</div>
</main>
</div>
<template id=cw-template>
$warningT
</template>
|]
last' :: [a] -> Maybe a
last' xs = if null xs then Nothing else Just $ last xs
makeArtist :: Maybe Artist -> Builder
makeArtist Nothing = ""
makeArtist (Just (Artist {name, url})) = [b|@0
<section id=desc class=info-section>
<h2>by</h2>
<div>$artistLink</div>
</section>
|]
where
artistLink = case url of
Just u -> [b|<a href="$u">$name</a>|]
Nothing -> [b|$name|]
makeDesc :: Desc -> Builder
makeDesc NoDesc = ""
makeDesc (TextDesc desc) = [b|@0
<section id=desc class=info-section>
<h2>about</h2>
<div>
$4.desc
</div>
</section>
|]
makeDesc (LongDesc fs) = [b|@0
<section id=desc class=info-section>
$2.fields
</section>
|]
where
fields = map makeField fs
makeField (DescField {name, text}) = [b|@0
<h2>$name</h2>
<div>
$4.text
</div>
|]
addIds :: Traversable t => t Image -> t (Image, Text)
addIds = snd . mapAccumL makeId Set.empty where
makeId used img = (Set.insert newId used, (img, newId)) where
newId = head $ filter (\i -> not $ i `Set.member` used) ids
ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]]
label = escId $ #label img
makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
makeButtonBar title images =
case images of
Uncat [] -> throw $ NoEligibleImages title
Uncat [_] -> ""
Cat [(_,[_])] -> ""
Uncat imgs -> makeNav "uncat" $ makeAlts imgs
Cat cats
| all ((<= 1) . length . snd) cats ->
makeButtonBar title $ Uncat $ flatten cats
| [(_, imgs)] <- cats ->
makeButtonBar title (Uncat imgs)
| otherwise ->
makeNav "cat" $ map (uncurry makeCat) cats
where
makeNav :: CanBuild b => Text -> b -> Builder
makeNav cls inner = [b|@0
<nav id=alts class=$cls aria-label="alternate versions">
$2.inner
$2.skipAll
</nav> |]
makeCat lbl imgs = [b|@0
<section>
<h3 class=alt-cat>$lbl</h3>
$0.alts
</section> |]
where alts = makeAlts imgs
makeAlts imgs = [b|@0
<ul class="buttonbar bb-choice">
$2.elems
</ul> |]
where elems = map (uncurry altButton) imgs
skipAll =
if any (isJust . #warning . fst) images then
[b|@0
<div class=buttonbar id=skipAllDiv>
<input type=checkbox name=skipAll id=skipAll>
<label for=skipAll>skip warnings</label>
</div>
|]
else ""
flatten :: [(Text, [(Image, a)])] -> [(Image, Text)]
flatten cats =
addIds [(img {label = cat}) | (cat, is) <- cats, (img, _) <- is]
altButton :: Image -> Text -> Builder
altButton img i = [b|@0
<li$nsfwClass>
<input type=radio name=variant id="$i" value="$path'"
data-link="$link"$warning'>
<label for="$i"$nsfwLabelClass>$label</label>
|]
where
Image {label, path, nsfw, warning, download} = img
nsfwClass = if nsfw then [b| class=nsfw|] else ""
nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
path' = pageFile path
link = fromMaybe (bigFile path) download
warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]
makeTags :: FilePath -> [Strict.Text] -> Builder
makeTags undir tags =
if null tags then "" else [b|@0
<nav id=tags class=info-section>
<h2>tags</h2>
<ul>
$4.tagList
</ul>
</nav>
|]
where
tagList = map makeTag tags
makeTag tag = [b|<li><a href="$undir#require_$tag'">$tag</a>|]
where tag' = escId tag
extLinks :: [Link] -> Builder
extLinks links =
if null links then "" else [b|@0
<nav id=links class=info-section>
<h2>links</h2>
<ul>
$4.linkList
</ul>
</nav>
|]
where linkList = map extLink links
extLink :: Link -> Builder
extLink (Link {title, url}) = [b|@8
<li>
<a href="$url">
$title
</a>
|]
makeUpdates :: [(Date, [Update])] -> Builder
makeUpdates ups =
if all (null . snd) ups then "" else [b|@4
<section id=updates class=info-section>
<h2>updates</h2>
<dl>
$8.updateList
</dl>
</section>
|]
where updateList = map (uncurry makeUpdate) ups
makeUpdate :: Date -> [Update] -> Builder
makeUpdate _ [] = ""
makeUpdate date ups = [b|@8
<dt>$date'
<dd>$desc
|] where
date' = formatSlash date
desc = mconcat $ map fromText $ intersperse "; " $ map #desc ups