gallery/make-pages/SinglePage.hs

365 lines
9.7 KiB
Haskell
Raw Normal View History

2024-07-07 20:47:18 -04:00
{-# LANGUAGE PatternSynonyms #-}
2020-07-09 00:20:09 -04:00
module SinglePage (make) where
2020-07-07 23:28:09 -04:00
2020-09-25 17:08:44 -04:00
import Date
2020-08-11 14:29:54 -04:00
import Info
2020-07-15 15:31:46 -04:00
import BuilderQQ
2020-10-06 16:07:39 -04:00
import qualified NsfwWarning
2020-07-12 22:01:31 -04:00
import Control.Exception
2022-01-03 14:45:55 -05:00
import Control.Monad
import Data.List (sort, intersperse)
import Data.Maybe (fromMaybe, isJust)
2020-07-07 23:28:09 -04:00
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
2022-05-16 04:25:16 -04:00
import System.FilePath (joinPath, splitPath)
2021-08-23 10:35:55 -04:00
import qualified Data.HashSet as Set
import Data.Traversable
2024-07-07 20:47:18 -04:00
import Data.Semigroup
import Data.List.NonEmpty (toList)
2020-07-12 23:02:16 -04:00
-- | e.g. only nsfw images are present for a non-nsfw page
2022-12-30 16:00:13 -05:00
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)"
2020-07-07 23:28:09 -04:00
2020-08-11 14:29:54 -04:00
make :: Text -- ^ website root
-> Text -- ^ website name
2020-08-11 14:29:54 -04:00
-> FilePath -- ^ gallery prefix
-> Bool -- ^ nsfw?
2020-08-08 19:22:00 -04:00
-> 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
2020-07-07 23:28:09 -04:00
make' :: Text -> Text -> FilePath -> Bool -> FilePath -> FilePath -> Info
-> IO Builder
make' root siteName prefix nsfw _dataDir dir
info@(Info {date, title, artist, bg}) = do
2024-07-07 20:47:18 -04:00
images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info
2020-08-08 19:22:00 -04:00
let undir = joinPath (replicate (length (splitPath dir)) "..")
2020-09-25 17:08:44 -04:00
let formattedDate = formatLong date
2020-08-08 19:22:00 -04:00
2021-08-23 10:35:55 -04:00
let buttonBar = makeButtonBar title $ addIds images
2022-12-30 16:00:13 -05:00
let image0 :| otherImages = allImages images
let download0 = fromMaybe (bigFile image0) image0.download
let path0' = pageFile image0
2020-08-08 19:22:00 -04:00
2024-07-07 13:45:50 -04:00
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
2020-08-08 19:22:00 -04:00
let makePrefetch img = [b|<link rel=prefetch href=$path'>|]
where path' = bigFile img
2022-05-16 04:25:16 -04:00
let prefetches = map makePrefetch otherImages
2020-08-08 19:22:00 -04:00
let makeWarning w = [b|
2020-08-08 19:22:00 -04:00
<figcaption id=cw aria-role=button tabindex=0>
2020-09-13 20:35:56 -04:00
<span id=cw-text>$w</span>
2020-08-08 19:22:00 -04:00
</figcaption>
|]
2024-08-05 13:20:01 -04:00
let warning' = ifJust image0.warning makeWarning
2020-09-13 20:34:21 -04:00
let warningT = makeWarning [b|.|]
2023-03-07 10:14:42 -05:00
let bgStyle = case bg of
Default -> ""
NoBorder -> [b|
2023-03-07 10:14:42 -05:00
<style>
#mainfig {
background: transparent;
border: none;
box-shadow: none;
}
</style>
|]
Other col -> [b|
2023-03-07 10:14:42 -05:00
<style> #mainfig { background: $col; } </style>
|]
2020-08-08 19:22:00 -04:00
let url = [b|$root/$prefix/$dir|]
2020-08-11 14:29:54 -04:00
let desc = case artist of
Just (Artist {name}) -> [b|by $name|]
2020-08-11 14:29:54 -04:00
Nothing -> "by niss"
let updateDate = ifJust (last' updates) \(d, _) ->
2020-11-16 17:30:56 -05:00
let updated = formatLong d in
[b|<br> <span class=updated>updated $updated</span>|]
2020-09-19 01:51:52 -04:00
2022-01-03 14:45:55 -05:00
let nsfw' = NsfwWarning.Single <$ guard nsfw
let nsfwScript = NsfwWarning.script nsfw'
let nsfwDialog = NsfwWarning.dialog nsfw'
2020-10-06 16:07:39 -04:00
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|
2020-07-12 22:01:31 -04:00
<!DOCTYPE html>
<html lang=en>
<meta charset=utf-8>
2020-08-04 12:59:09 -04:00
<meta name=viewport content="width=1200,viewport-fit=cover">
2020-08-04 17:12:58 -04:00
<link rel=stylesheet href=/style/shiny/single.css>
2020-08-04 18:52:56 -04:00
<link rel=icon href=/style/niss.svg>
2020-07-17 06:29:13 -04:00
<meta property=og:type content=article>
<meta property=og:title content="$title">
<meta property=og:site_name content="$siteName">
2020-08-11 14:29:54 -04:00
<meta property=og:description content="$desc">
<meta property=og:url content="$url">
$imageMeta
2020-08-11 14:29:54 -04:00
2022-11-12 06:14:42 -05:00
<meta name=robots content='noai,noimageai'>
2023-09-06 19:17:21 -04:00
<script src=/script/single.js type=module></script>
2020-10-06 16:07:39 -04:00
$nsfwScript
$bgStyle
2020-08-03 13:32:40 -04:00
$prefetches
2020-07-25 07:59:04 -04:00
<title>$title</title>
2020-07-12 22:01:31 -04:00
2020-10-06 16:07:39 -04:00
$nsfwDialog
2020-07-12 22:01:31 -04:00
2020-10-06 16:07:39 -04:00
<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>
2020-10-06 16:07:39 -04:00
</header>
2020-07-17 06:29:13 -04:00
$buttonBar
2020-07-12 22:01:31 -04:00
2020-10-06 16:07:39 -04:00
<main>
2022-05-16 04:25:16 -04:00
<figure id=mainfig>
2020-10-06 16:07:39 -04:00
$warning'
<a id=mainlink href="$download0" title="download full version">
<img id=mainimg src="$path0'" alt="">
</a>
</figure>
2020-07-12 22:01:31 -04:00
2020-10-06 16:07:39 -04:00
<div id=info>
$artistSection
2024-07-07 13:45:50 -04:00
$descSection
2020-07-12 22:01:31 -04:00
$updatesList
2020-09-19 01:51:52 -04:00
$linksList
2020-10-06 16:07:39 -04:00
$tagsList
2020-10-06 16:07:39 -04:00
</div>
</main>
</div>
2020-09-13 20:34:21 -04:00
<template id=cw-template>
$warningT
</template>
2020-07-12 22:01:31 -04:00
|]
2020-07-17 06:29:13 -04:00
2020-11-16 17:30:56 -05:00
last' :: [a] -> Maybe a
last' xs = if null xs then Nothing else Just $ last xs
2024-07-07 13:45:50 -04:00
makeArtist :: Maybe Artist -> Builder
makeArtist Nothing = ""
makeArtist (Just (Artist {name, url})) = [b|
2024-07-07 13:45:50 -04:00
<section id=desc class=info-section>
<h2>by</h2>
<div>$artistLink</div>
</section>
|]
2020-07-14 00:51:46 -04:00
where
artistLink = case url of
Just u -> [b|<a href="$u">$name</a>|]
Nothing -> [b|$name|]
2020-07-14 00:51:46 -04:00
makeDesc :: Desc -> Builder
makeDesc NoDesc = ""
makeDesc (TextDesc desc) = [b|
<section id=desc class=info-section>
2020-08-03 13:36:48 -04:00
<h2>about</h2>
<div>
$desc
2020-08-03 13:36:48 -04:00
</div>
</section>
2020-07-12 22:01:31 -04:00
|]
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>
|]
2020-07-07 23:28:09 -04:00
2024-07-07 20:47:18 -04:00
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
2022-05-16 04:25:16 -04:00
addIds :: Traversable t => t Image -> t (Image, Text)
2021-08-23 10:35:55 -04:00
addIds = snd . mapAccumL makeId Set.empty where
2022-05-16 04:25:16 -04:00
makeId used img = (Set.insert newId used, (img, newId)) where
2024-07-07 20:47:18 -04:00
newId = headI $ filterI (\i -> not $ i `Set.member` used) ids
ids = fmap (\i -> toStrictText [b|$label$i|]) suffixes
label = escId $ img.label
2021-08-23 10:35:55 -04:00
2024-07-07 20:47:18 -04:00
pattern One :: a -> NonEmpty a
pattern One x = x :| []
2022-05-16 04:25:16 -04:00
makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
2020-07-25 07:58:53 -04:00
makeButtonBar title images =
2021-03-12 23:30:28 -05:00
case images of
2024-07-07 20:47:18 -04:00
Uncat (One _) -> ""
Cat (One (_, One _)) -> ""
Uncat imgs -> makeNav "uncat" $ makeAlts imgs
Cat cats
2024-07-07 20:47:18 -04:00
| all ((== 1) . length . snd) cats ->
makeButtonBar title $ Uncat $ flatten cats
2022-11-12 06:13:02 -05:00
| [(_, imgs)] <- cats ->
makeButtonBar title (Uncat imgs)
| otherwise ->
2024-07-07 20:47:18 -04:00
makeNav "cat" $ fmap (uncurry makeCat) cats
2021-08-23 10:30:11 -04:00
where
2024-07-07 14:04:38 -04:00
makeNav :: CanBuild b => Text -> b -> Builder
makeNav cls inner = [b|
2022-12-26 16:04:57 -05:00
<nav id=alts class=$cls aria-label="alternate versions">
$inner
$skipAll
2022-12-26 16:04:57 -05:00
</nav> |]
makeCat lbl imgs = [b|
2022-12-26 16:04:57 -05:00
<section>
<h3 class=alt-cat>$lbl</h3>
$alts
2022-12-26 16:04:57 -05:00
</section> |]
where alts = makeAlts imgs
makeAlts imgs = [b|
2022-12-26 16:04:57 -05:00
<ul class="buttonbar bb-choice">
$elems
2022-12-26 16:04:57 -05:00
</ul> |]
2024-07-07 20:47:18 -04:00
where elems = fmap (uncurry altButton) imgs
2022-12-26 16:04:57 -05:00
skipAll =
if any (isJust . (.warning) . fst) images then
[b|
2022-12-26 16:04:57 -05:00
<div class=buttonbar id=skipAllDiv>
<input type=checkbox name=skipAll id=skipAll>
<label for=skipAll>skip warnings</label>
</div>
|]
2024-07-07 13:45:50 -04:00
else ""
2024-07-07 20:47:18 -04:00
flatten :: NonEmpty (Text, NonEmpty (Image, a)) -> NonEmpty (Image, Text)
flatten =
addIds . sconcat .
fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is)
2022-05-16 04:25:16 -04:00
altButton :: Image -> Text -> Builder
altButton img i = [b|
2020-07-12 22:01:31 -04:00
<li$nsfwClass>
2021-08-23 10:35:55 -04:00
<input type=radio name=variant id="$i" value="$path'"
2022-05-16 04:25:16 -04:00
data-link="$link"$warning'>
2021-08-23 10:35:55 -04:00
<label for="$i"$nsfwLabelClass>$label</label>
2020-07-12 22:01:31 -04:00
|]
2020-07-07 23:28:09 -04:00
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
2020-09-13 20:33:27 -04:00
warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]
2020-07-07 23:28:09 -04:00
2020-08-04 13:05:20 -04:00
makeTags :: FilePath -> [Strict.Text] -> Builder
makeTags undir tags =
if null tags then "" else [b|
2020-08-04 12:26:36 -04:00
<nav id=tags class=info-section>
2020-07-12 22:01:31 -04:00
<h2>tags</h2>
2022-12-29 21:19:33 -05:00
<ul>
$tagList
2020-07-12 22:01:31 -04:00
</ul>
2020-08-04 12:26:36 -04:00
</nav>
2020-07-12 22:01:31 -04:00
|]
2020-07-11 23:42:31 -04:00
where
2020-07-12 22:01:31 -04:00
tagList = map makeTag tags
makeTag tag = [b|<li><a href="$undir#require_$tag'">$tag</a>|]
2020-08-04 13:05:20 -04:00
where tag' = escId tag
2020-07-11 23:42:31 -04:00
2020-08-03 13:36:48 -04:00
extLinks :: [Link] -> Builder
extLinks links =
if null links then "" else [b|
2020-08-04 12:26:36 -04:00
<nav id=links class=info-section>
2020-07-12 22:01:31 -04:00
<h2>links</h2>
<ul>
$linkList
2020-07-12 22:01:31 -04:00
</ul>
2020-08-04 12:26:36 -04:00
</nav>
2020-07-12 22:01:31 -04:00
|]
2020-08-03 13:36:48 -04:00
where linkList = map extLink links
2020-07-07 23:28:09 -04:00
extLink :: Link -> Builder
extLink (Link {title, url}) = [b|
2020-07-12 22:01:31 -04:00
<li>
<a href="$url">
$title
2020-07-12 22:01:31 -04:00
</a>
|]
2020-07-31 20:27:24 -04:00
makeUpdates :: [(Date, NonEmpty Update)] -> Builder
2020-09-19 01:51:52 -04:00
makeUpdates ups =
if all (null . snd) ups then "" else [b|
2020-09-19 01:51:52 -04:00
<section id=updates class=info-section>
<h2>updates</h2>
<dl>
$updateList
2020-09-19 01:51:52 -04:00
</dl>
</section>
|]
where updateList = fmap (uncurry makeUpdate) ups
2020-09-19 01:51:52 -04:00
makeUpdate :: Date -> NonEmpty Update -> Builder
makeUpdate date ups = [b|
2020-09-19 01:51:52 -04:00
<dt>$date'
2020-11-16 17:30:56 -05:00
<dd>$desc
|] where
date' = formatSlash date
desc = mconcat $ map fromText $ intersperse "; " $ toList $ fmap (.desc) ups