gallery/make-pages/GalleryPage.hs
2021-04-16 23:48:56 +02:00

157 lines
4.6 KiB
Haskell

{-# LANGUAGE TransformListComp #-}
module GalleryPage (make) where
import BuilderQQ
import Date
import Info
import Data.Foldable
import Data.Function (on, (&))
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (intersperse, groupBy, sortOn)
import qualified Data.Text.Lazy as Lazy
import System.FilePath (takeDirectory, joinPath, splitPath)
import GHC.Exts (Down (..), the)
make :: Text -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text
make root ginfo infos = toLazyText $ make' root ginfo infos
make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder
make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<!DOCTYPE html>
<html lang=en>
<meta charset=utf-8>
<link rel=stylesheet href=/style/shiny/gallery.css>
<link rel=icon href=/style/niss.svg>
<link rel=alternate href=rss.xml type=application/rss+xml>
<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/$imagepath0">
<meta property=og:url content="$url">
<meta name=twitter:site content=@2_gecs>
<meta name=twitter:card content=summary>
<script src=/script/gallery.js></script>
<title>$title</title>
<header>
<h1>$title</h1>
<h2 class="right corner">
<a href=rss.xml>rss</a>
</h2>
</header>
<nav id=filters>
<details id=filters-details>
<summary><h2>filters</h2></summary>
<div>
<h3>show only</h3>
<ul id=require class="buttonbar bb-choice">
$8.requireFilters
</ul>
<h3>exclude</h3>
<ul id=exclude class="buttonbar bb-choice">
$8.excludeFilters
</ul>
<a href=# id=clear>clear</a>
<a href=# id=singles>toggle single-use tags</a>
</div>
</details>
</nav>
<main>
<ul class=grid>
$4.items
</ul>
</main>
<footer>
<a href=$undir>all galleries</a>
</footer>
|]
where
items = map (uncurry $ makeYearItems nsfw) infosByYear
infosByYear =
[(the year, infopath) |
infopath@(_, info) <- infos,
then sortOn by Down info,
let year = #latestYear info,
then group by Down year using groupBy']
groupBy' f = groupBy ((==) `on` f)
undir = joinPath (replicate (length (splitPath prefix)) "..")
allTags = infos
& concatMap (map (,1) . tagsFor nsfw . #second)
& HashMap.fromListWith (+) & HashMap.toList
& sortOn (\(tag, count) -> (Down count, tag))
requireFilters = map (uncurry $ makeFilter "require" mempty) allTags
excludeFilters = map (uncurry $ makeFilter "exclude" hidden) allTags
nsfw = #nsfw filters /= NoNsfw
url = [b|$root/$prefix|]
imagepath0
| (_, (p0, i0) : _) : _ <- infosByYear = getThumb (takeDirectory p0) i0
| otherwise = "/style/card.png"
makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder
makeFilter prefix initial tag count = [b|@8
<li>
<input type=checkbox id="$id'" value="$tag"$checked>
<label for="$id'" data-count=$count>$tag</label>
|]
where
id' = [b|$prefix$&_$tag'|]
tag' = escId tag
checked = if HashSet.member tag initial then [b| checked|] else ""
makeYearItems :: Bool -- ^ nsfw
-> Int -- ^ year
-> [(FilePath, Info)]
-> Builder
makeYearItems nsfw year infos = [b|@4
<li class="item year-marker" id="marker-$year">
<span class=year-text>$year'</span>
$4.items
|]
where
items = map (uncurry $ makeItem nsfw) infos
year' = show year & foldMap \c -> [b|<span class=y>$c</span>|]
makeItem :: Bool -> FilePath -> Info -> Builder
makeItem nsfw file info@(Info {title, bg}) = [b|@4
<li class="item post$nsfw'" data-date="$date'" data-year=$year'
data-updated="$updated'"
data-tags="$tags'">
<figure>
<a href="$dir">
<img src="$thumb" loading=lazy$bgStyle>
</a>
<figcaption>
<span class=date>$date'</span>
<span class=title>$title</span>
</figcaption>
</figure>
|]
where
dir = takeDirectory file
thumb = getThumb dir info
nsfw' = if nsfw && #anyNsfw info then [b| nsfw|] else ""
tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info
date = #latestDate info
date' = formatShort date
year' = #year date
updated' = if #updated info then [b|true|] else [b|false|]
bgStyle = ifJust bg \col -> [b| style="background: $col"|]