gallery/make-pages/SinglePage.hs

254 lines
7.3 KiB
Haskell

module SinglePage (make) where
import Info
import BuilderQQ
import Records ()
import Control.Exception
import Data.Maybe (fromMaybe)
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import qualified Data.Time.Calendar as Time
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 = formatDate 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 descSection = makeDesc $ descFor nsfw info
let tagsList = makeTags undir $ tagsFor nsfw info
let linksList = extLinks $ linksFor nsfw info
let makePrefetch (Image {path}) = [b|<link rel=prefetch href=$path>|]
let prefetches = map (makePrefetch . #first) $ tail images
let makeWarning w = [b|@4
<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
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=@gec_ko_>
<meta name=twitter:card content=summary>
<script src=/script/single.js></script>
$bgStyle
$0.prefetches
<title>$title</title>
<header>
<h1>$title</h1>
$artistTag
<h2 id=date class="right corner">$formattedDate</h2>
</header>
$buttonBar
<main>
<figure id=mainfig data-width=$width0 data-height=$height0>
$warning'
<a id=mainlink href="$download0" title="download full version">
<img id=mainimg src="$path0'" alt="">
</a>
</figure>
<div id=info>
$descSection
$tagsList
$linksList
</div>
</main>
<footer>
<a href=$undir>back to gallery</a>
</footer>
<template id=cw-template>
$warningT
</template>
|]
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|@4
<section id=desc class=info-section>
<h2>about</h2>
<div>
$8.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|@4
<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|@4
<nav id=tags class=info-section>
<h2>tags</h2>
<ul class="buttonbar bb-links">
$8.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|@4
<nav id=links class=info-section>
<h2>links</h2>
<ul class="buttonbar bb-links">
$8.linkList
</ul>
</nav>
|]
where linkList = map extLink links
extLink :: Link -> Builder
extLink (Link {title, url}) = [b|@8
<li>
<a href="$url">
$title
</a>
|]
formatDate :: Day -> Builder
formatDate date = [b|$week $day $month $year|] where
(year, month', day') = Time.toGregorian date
week' = Time.dayOfWeek date
day = nth day'
month = Strict.words "january february march april may june july \
\august september october november december"
!! (month' - 1)
week = Strict.words "mon tue wed thu fri sat sun" !! (fromEnum week' - 1)
nth :: Int -> Builder
nth n = [b|$n$suf|] where
suf | n >= 10, n <= 19 = [b|th|]
| n `mod` 10 == 1 = [b|st|]
| n `mod` 10 == 2 = [b|nd|]
| n `mod` 10 == 3 = [b|rd|]
| otherwise = [b|th|]
data Size = Size {width, height :: !Int} deriving (Eq, Show)
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)