gallery/make-pages/SinglePage.hs

281 lines
7.8 KiB
Haskell

module SinglePage (make) where
import Date
import Info
import BuilderQQ
import Records ()
import qualified NsfwWarning
import Control.Exception
import Data.List (sort)
import Data.Maybe (fromMaybe)
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import System.FilePath (joinPath, splitPath, (</>))
import qualified System.Process as Proc
import Text.Read (readMaybe)
-- | e.g. only nsfw images are present for a non-nsfw page
data 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
-> FilePath -- ^ gallery prefix
-> Bool -- ^ nsfw?
-> FilePath -- ^ data dir
-> FilePath -- ^ subdir of datadir containing this @info.yaml@
-> Info -> IO Lazy.Text
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}) = do
images <- withSizes (dataDir </> dir) $ imagesFor nsfw info
let undir = joinPath (replicate (length (splitPath dir)) "..")
let artistTag = ifJust artist makeArtist
let formattedDate = formatLong date
let buttonBar = makeButtonBar title images
let (image0@(Image {path = path0, download = download0'}),
Size {width = width0, height = height0})
= head images
let download0 = fromMaybe path0 download0'
let path0' = pageFile path0
let tinyCls = if any (tiny . #second) images then [b| class=tiny|] else ""
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>|]
let prefetches = map (makePrefetch . #first) $ tail images
let makeWarning w = [b|@0
<figcaption id=cw aria-role=button tabindex=0>
<span id=cw-text>$w</span>
</figcaption>
|]
let warning' = ifJust (#warning image0) makeWarning
let warningT = makeWarning [b|.|]
let bgStyle = ifJust bg \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) \(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
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=og:website>
<meta property=og:title content="$title">
<meta property=og:site_name content="$title">
<meta property=og:description content="$desc">
<meta property=og:image content="$url/$thumb">
<meta property=og:url content="$url">
<meta name=twitter:site content=@2_gecs>
<meta name=twitter:card content=summary>
<script src=/script/single.js></script>
$nsfwScript
$bgStyle
$0.prefetches
<title>$title</title>
$nsfwDialog
<div class=page>
<header>
<h1>$title</h1>
$artistTag
<h2 id=date class="right corner">
$formattedDate $updateDate
</h2>
</header>
$2.buttonBar
<main>
<figure id=mainfig data-width=$width0 data-height=$height0$tinyCls>
$warning'
<a id=mainlink href="$download0" title="download full version">
<img id=mainimg src="$path0'" alt="">
</a>
</figure>
<div id=info>
$6.descSection
$6.tagsList
$6.linksList
$6.updatesList
</div>
</main>
<footer>
<a href=$undir>back to gallery</a>
</footer>
</div>
<template id=cw-template>
$warningT
</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>|]
where
artistLink = case url of
Just u -> [b|<a href="$u">$name</a>|]
Nothing -> [b|$name|]
makeDesc :: Maybe Strict.Text -> Builder
makeDesc mdesc = ifJust mdesc \desc -> [b|@0
<section id=desc class=info-section>
<h2>about</h2>
<div>
$4.desc
</div>
</section>
|]
makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder
makeButtonBar title images =
case length images of
0 -> throw $ NoEligibleImages title
1 -> ""
_ -> [b|@0
<nav id=alts aria-label="alternate versions">
<ul class="buttonbar bb-choice">
$4.alts
</ul>
</nav>
|]
where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images
altButton :: Int -> Image -> Size -> Builder
altButton i (Image {label, path, nsfw, warning}) (Size {width, height}) = [b|@0
<li$nsfwClass>
<input type=radio$checked name=variant id="$idLabel" value="$path'"
data-link="$path"$warning'
data-width=$width data-height=$height>
<label for="$idLabel"$nsfwLabelClass>$label</label>
|]
where
nsfwClass = if nsfw then [b| class=nsfw|] else ""
nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
checked = if i == 0 then [b| checked|] else ""
idLabel = escId label
path' = pageFile path
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 class="buttonbar bb-links">
$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 class="buttonbar bb-links">
$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 :: [Update] -> Builder
makeUpdates ups =
if null ups then "" else [b|@4
<section id=updates class=info-section>
<h2>updates</h2>
<dl>
$8.updateList
</dl>
</section>
|]
where updateList = map makeUpdate ups
makeUpdate :: Update -> Builder
makeUpdate (Update {date, desc}) = [b|@8
<dt>$date'
<dd>$desc
|]
where date' = formatSlash date
data Size = Size {width, height :: !Int} deriving (Eq, Show)
tiny :: Size -> Bool
tiny (Size {width, height}) = width < 250 || height < 250
imageSize :: FilePath -> FilePath -> IO Size
imageSize dir img = do
-- "[0]" to get the first frame of an animation
-- otherwise it prints a pair for each frame
let filename = (dir </> img) ++ "[0]"
output <- Proc.readProcess "identify" ["-format", "(%W,%H)", filename] ""
case readMaybe output of
Just (width, height) -> pure $ Size {width, height}
Nothing -> fail $ "couldn't understand identify output:\n" ++ output
withSizes :: FilePath -> [Image] -> IO [(Image, Size)]
withSizes dir = traverse \img -> do
size <- imageSize dir $ #path img
pure (img, size)