365 lines
9.7 KiB
Haskell
365 lines
9.7 KiB
Haskell
{-# LANGUAGE PatternSynonyms #-}
|
|
module SinglePage (make) where
|
|
|
|
import Date
|
|
import Info
|
|
import BuilderQQ
|
|
import qualified NsfwWarning
|
|
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import Data.List (sort, intersperse)
|
|
import Data.Maybe (fromMaybe, 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
|
|
import Data.Semigroup
|
|
import Data.List.NonEmpty (toList)
|
|
|
|
|
|
-- | 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
|
|
images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info
|
|
|
|
let undir = joinPath (replicate (length (splitPath dir)) "..")
|
|
|
|
let formattedDate = formatLong date
|
|
|
|
let buttonBar = makeButtonBar title $ addIds images
|
|
|
|
let image0 :| otherImages = allImages images
|
|
let download0 = fromMaybe (bigFile image0) image0.download
|
|
let path0' = pageFile image0
|
|
|
|
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 img = [b|<link rel=prefetch href=$path'>|]
|
|
where path' = bigFile img
|
|
let prefetches = map makePrefetch otherImages
|
|
|
|
let makeWarning w = [b|
|
|
<figcaption id=cw aria-role=button tabindex=0>
|
|
<span id=cw-text>$w</span>
|
|
</figcaption>
|
|
|]
|
|
|
|
let warning' = ifJust image0.warning makeWarning
|
|
let warningT = makeWarning [b|.|]
|
|
|
|
let bgStyle = case bg of
|
|
Default -> ""
|
|
NoBorder -> [b|
|
|
<style>
|
|
#mainfig {
|
|
background: transparent;
|
|
border: none;
|
|
box-shadow: none;
|
|
}
|
|
</style>
|
|
|]
|
|
Other col -> [b|
|
|
<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 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 = case previewImage info of
|
|
Just (PFull (Image {path})) -> [b|
|
|
<meta property=og:image content="$url/$path">
|
|
<meta name=twitter:card content=summary_large_image>
|
|
<meta name=twitter:image content="$url/$path">
|
|
|]
|
|
Just (PThumb path) -> [b|
|
|
<meta property=og:image content="$url/$path">
|
|
<meta name=twitter:card content=summary>
|
|
|]
|
|
Nothing -> throw $ NoThumb dir
|
|
|
|
pure [b|
|
|
<!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
|
|
|
|
$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>
|
|
|
|
$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>
|
|
$artistSection
|
|
|
|
$descSection
|
|
|
|
$updatesList
|
|
|
|
$linksList
|
|
|
|
$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|
|
|
<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|
|
|
<section id=desc class=info-section>
|
|
<h2>about</h2>
|
|
<div>
|
|
$desc
|
|
</div>
|
|
</section>
|
|
|]
|
|
makeDesc (LongDesc fs) = [b|
|
|
<section id=desc class=info-section>
|
|
$fields
|
|
</section>
|
|
|]
|
|
where
|
|
fields = map makeField fs
|
|
makeField (DescField {name, text}) = [b|
|
|
<h2>$name</h2>
|
|
<div>
|
|
$text
|
|
</div>
|
|
|]
|
|
|
|
|
|
data Inf a = a :> Inf a deriving Functor
|
|
|
|
headI :: Inf a -> a
|
|
headI (x :> _) = x
|
|
|
|
suffixes :: Inf String
|
|
suffixes = "" :> go 0 where
|
|
go :: Int -> Inf String
|
|
go i = show i :> go (i + 1)
|
|
|
|
filterI :: (a -> Bool) -> Inf a -> Inf a
|
|
filterI p (x :> xs) = if p x then x :> filterI p xs else filterI p xs
|
|
|
|
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 = headI $ filterI (\i -> not $ i `Set.member` used) ids
|
|
ids = fmap (\i -> toStrictText [b|$label$i|]) suffixes
|
|
label = escId $ img.label
|
|
|
|
|
|
pattern One :: a -> NonEmpty a
|
|
pattern One x = x :| []
|
|
|
|
makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
|
|
makeButtonBar title images =
|
|
case images of
|
|
Uncat (One _) -> ""
|
|
Cat (One (_, One _)) -> ""
|
|
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" $ fmap (uncurry makeCat) cats
|
|
where
|
|
makeNav :: CanBuild b => Text -> b -> Builder
|
|
makeNav cls inner = [b|
|
|
<nav id=alts class=$cls aria-label="alternate versions">
|
|
$inner
|
|
$skipAll
|
|
</nav> |]
|
|
makeCat lbl imgs = [b|
|
|
<section>
|
|
<h3 class=alt-cat>$lbl</h3>
|
|
$alts
|
|
</section> |]
|
|
where alts = makeAlts imgs
|
|
makeAlts imgs = [b|
|
|
<ul class="buttonbar bb-choice">
|
|
$elems
|
|
</ul> |]
|
|
where elems = fmap (uncurry altButton) imgs
|
|
skipAll =
|
|
if any (isJust . (.warning) . fst) images then
|
|
[b|
|
|
<div class=buttonbar id=skipAllDiv>
|
|
<input type=checkbox name=skipAll id=skipAll>
|
|
<label for=skipAll>skip warnings</label>
|
|
</div>
|
|
|]
|
|
else ""
|
|
|
|
flatten :: NonEmpty (Text, NonEmpty (Image, a)) -> NonEmpty (Image, Text)
|
|
flatten =
|
|
addIds . sconcat .
|
|
fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is)
|
|
|
|
altButton :: Image -> Text -> Builder
|
|
altButton img i = [b|
|
|
<li$nsfwClass>
|
|
<input type=radio name=variant id="$i" value="$path'"
|
|
data-link="$link"$warning'>
|
|
<label for="$i"$nsfwLabelClass>$label</label>
|
|
|]
|
|
where
|
|
Image {label, nsfw, warning, download} = img
|
|
nsfwClass = if nsfw then [b| class=nsfw|] else ""
|
|
nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
|
|
path' = pageFile img
|
|
link = fromMaybe (bigFile img) download
|
|
warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]
|
|
|
|
makeTags :: FilePath -> [Strict.Text] -> Builder
|
|
makeTags undir tags =
|
|
if null tags then "" else [b|
|
|
<nav id=tags class=info-section>
|
|
<h2>tags</h2>
|
|
<ul>
|
|
$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|
|
|
<nav id=links class=info-section>
|
|
<h2>links</h2>
|
|
<ul>
|
|
$linkList
|
|
</ul>
|
|
</nav>
|
|
|]
|
|
where linkList = map extLink links
|
|
|
|
extLink :: Link -> Builder
|
|
extLink (Link {title, url}) = [b|
|
|
<li>
|
|
<a href="$url">
|
|
$title
|
|
</a>
|
|
|]
|
|
|
|
makeUpdates :: [(Date, NonEmpty Update)] -> Builder
|
|
makeUpdates ups =
|
|
if all (null . snd) ups then "" else [b|
|
|
<section id=updates class=info-section>
|
|
<h2>updates</h2>
|
|
<dl>
|
|
$updateList
|
|
</dl>
|
|
</section>
|
|
|]
|
|
where updateList = fmap (uncurry makeUpdate) ups
|
|
|
|
makeUpdate :: Date -> NonEmpty Update -> Builder
|
|
makeUpdate date ups = [b|
|
|
<dt>$date'
|
|
<dd>$desc
|
|
|] where
|
|
date' = formatSlash date
|
|
desc = mconcat $ map fromText $ intersperse "; " $ toList $ fmap (.desc) ups
|