gallery/make-pages/SinglePage.hs

321 lines
9.1 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)
import qualified Data.HashSet as Set
import Data.Traversable
-- | 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 $ addIds images
let (image0@(Image {path = path0, download = download0'}),
Size {width = width0, height = height0}) : otherImages
= #all 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) otherImages
let makeWarning w = [b|@0
<figcaption id=cw aria-role=button tabindex=0>
<span id=cw-text>$w</span>
</figcaption>
|]
let defWarning = "oops i forgot to put one, sorry!<br>\
\if you can let me know i'd appreciate it" :: Text
let warning'
| Just w <- #warning image0 = makeWarning w
| #nsfw image0 = makeWarning defWarning
| otherwise = mempty
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 :: 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 :: Images' (Image, a) -> Images' (Image, a, Text)
addIds = snd . mapAccumL makeId Set.empty where
makeId used (img, x) = (Set.insert newId used, (img, x, 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, Size, Text) -> Builder
makeButtonBar title images =
case images of
Uncat [] -> throw $ NoEligibleImages title
Uncat [_] -> ""
Cat [(_,[_])] -> ""
Uncat imgs -> makeNav "uncat" $ makeAlts imgs
Cat cats -> makeNav "cat" $ map (uncurry makeCat) cats
where
makeNav (cls :: Text) inner = [b|@0
<nav id=alts class=$cls aria-label="alternate versions">
$2.inner
</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 (\(img,sz,i) -> altButton img sz i) imgs
altButton :: Image -> Size -> Text -> Builder
altButton img size i = [b|@0
<li$nsfwClass>
<input type=radio name=variant id="$i" value="$path'"
data-link="$link"$warning'
data-width=$width data-height=$height>
<label for="$i"$nsfwLabelClass>$label</label>
|]
where
Image {label, path, nsfw, warning, download} = img
Size {width, height} = size
nsfwClass = if nsfw then [b| class=nsfw|] else ""
nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
path' = pageFile path
link = fromMaybe 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 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 :: Traversable t => FilePath -> t Image -> IO (t (Image, Size))
withSizes dir = traverse \img -> do
size <- imageSize dir $ #path img
pure (img, size)