gallery/make-pages/GalleryPage.hs

module GalleryPage (make) where

import BuilderQQ
import Date
import Info
import qualified NsfwWarning

import Control.Monad
import Data.Foldable
import Data.Function ((&))
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (intersperse, sort, sortOn)
import Data.Maybe
import Data.Ord (Down (..))
import qualified Data.Text.Lazy as Lazy
import System.FilePath (takeDirectory, joinPath, splitPath)

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|
    <!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/style/card.png">
    <meta property=og:url content="$url">
    <meta name=twitter:site content=@2_gecs>
    <meta name=twitter:card content=summary>

    <meta name=robots content='noai,noimageai'>

    <script src=/script/gallery.js type=module></script>
    $nsfwScript

    <title>$title</title>

    $nsfwDialog

    <div class=page>
      <header>
        <h1>$title</h1>
        <a class="right corner" href=rss.xml>rss</a>
        <a class="left corner" href=$undir>back</a>
      </header>

      <nav id=filters>
        <details id=filters-details>
          <summary><h2>filters</h2></summary>
          <div>
            <h3>show only</h3>
            <ul id=require class=filterlist>
              $requireFilters
            </ul>

            <h3>exclude</h3>
            <ul id=exclude class=filterlist>
              $excludeFilters
            </ul>

            <ul id=filterstuff>
              <li><a href=# id=clear>clear</a>
              <li><a href=# id=sortalpha>sort by name</a>
              <li><a href=# id=sortuses>sort by uses</a>
              <li><a href=# id=singles>toggle single-use tags</a>
            </ul>
          </div>
        </details>
      </nav>

      <main>
        $items
      </main>
    </div>
  |]
 where
  items = map (uncurry $ makeYearItems nsfw) infosByYear

  infosByYear :: [(Int, [(FilePath, Info)])]
  infosByYear = infos &
    filter (not . (.unlisted) . snd) &
    sortOn (Down . compareKeyFor nsfw . snd) &
    groupOnKey (\(_, i) -> latestYearFor nsfw i)

  undir = joinPath (replicate (length (splitPath prefix)) "..")

  allTags = infos
    & concatMap (map (,1) . tagsFor nsfw . snd)
    & HashMap.fromListWith (+) & HashMap.toList
    & sort

  requireFilters = map (uncurry $ makeFilter "require" mempty) allTags
  excludeFilters = map (uncurry $ makeFilter "exclude" hidden) allTags

  nsfw = filters.nsfw /= NoNsfw

  url = [b|$root/$prefix|]

  nsfw'      = NsfwWarning.Gallery <$ guard nsfw
  nsfwScript = NsfwWarning.script nsfw'
  nsfwDialog = NsfwWarning.dialog nsfw'

-- from @extra@
groupOnKey :: Eq k => (a -> k) -> [a] -> [(k, [a])]
groupOnKey _ []     = []
groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no where
  fx        = f x
  (yes, no) = span (\y -> fx == f y) xs

makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder
makeFilter prefix initial tag count = [b|
    <li$hidden>
      <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 ""
  hidden = if count <= 1 then [b|$& hidden|] else ""

makeYearItems :: Bool -- ^ nsfw
              -> Int -- ^ year
              -> [(FilePath, Info)]
              -> Builder
makeYearItems nsfw year infos = [b|
    <h2 class="item year-marker" id="marker-$year" aria-label=$year>
      $year'
    </h2>
    $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 {bg}) = [b|
    <figure class="item post$nsfw'" data-year=$year' data-updated="$updated'"
        data-tags="$tags'">
      <a href="$dir">
        <img src="$thumbnail" loading=lazy$bgStyle
          width=200 height=200
          title="$tooltip">
      </a>
    </figure>
  |]
 where
  title     = fromMaybe info.title info.galleryTitle
  dir       = takeDirectory file
  thumbnail = getThumb dir info
  nsfw'     = if nsfw && anyNsfw info then [b|$& nsfw|] else ""
  tags'     = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info
  date      = latestDateFor nsfw info
  date'     = formatTooltip date
  year'     = date.year
  updated'  = if hasUpdatesFor nsfw info then [b|true|] else [b|false|]
  bgStyle   = case bg of Other col -> [b|$& style="background: $col"|]; _ -> ""
  tooltip   = [b|$title ($upd$date')|]
    where upd = if hasUpdatesFor nsfw info then "updated " else "" :: Builder
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`module GalleryPage (make) where`

add support for approx dates 2020-09-25 17:08:44 -04:00			`import BuilderQQ`
			`import Date`
			`import Info`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`import qualified NsfwWarning`
add support for approx dates 2020-09-25 17:08:44 -04:00
messing with the nsfw warning 2022-01-03 14:45:55 -05:00			`import Control.Monad`
add tags to gallery items 2020-08-03 17:07:59 -04:00			`import Data.Foldable`
remove TransformListComp which panics in ghc ≥ 9.6 2024-07-07 10:22:14 -04:00			`import Data.Function ((&))`
add tags to gallery items 2020-08-03 17:07:59 -04:00			`import qualified Data.HashMap.Strict as HashMap`
support initially-hidden tags 2020-08-03 20:27:19 -04:00			`import Data.HashSet (HashSet)`
			`import qualified Data.HashSet as HashSet`
remove TransformListComp which panics in ghc ≥ 9.6 2024-07-07 10:22:14 -04:00			`import Data.List (intersperse, sort, sortOn)`
allow separate title in gallery e.g. to avoid spoilers 2022-02-27 17:48:35 -05:00			`import Data.Maybe`
remove TransformListComp which panics in ghc ≥ 9.6 2024-07-07 10:22:14 -04:00			`import Data.Ord (Down (..))`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`import qualified Data.Text.Lazy as Lazy`
add twitter [etc] card previews 2020-08-11 14:29:54 -04:00			`import System.FilePath (takeDirectory, joinPath, splitPath)`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00
add twitter [etc] card previews 2020-08-11 14:29:54 -04:00			`make :: Text -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text`
			`make root ginfo infos = toLazyText $ make' root ginfo infos`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00
pass index file to gallery/rss (instead of trying to escape the strings inside in make & on the command line) 2020-08-03 20:25:59 -04:00
add twitter [etc] card previews 2020-08-11 14:29:54 -04:00			`make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b\|`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`<!DOCTYPE html>`
			`<html lang=en>`
			`<meta charset=utf-8>`
remove old title attr on stylesheets 2020-08-04 17:12:58 -04:00			`<link rel=stylesheet href=/style/shiny/gallery.css>`
add [temporary] favicon 2020-08-04 18:52:56 -04:00			`<link rel=icon href=/style/niss.svg>`
add rss [fixes #1] 2020-07-19 12:04:40 -04:00			`<link rel=alternate href=rss.xml type=application/rss+xml>`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00
add twitter [etc] card previews 2020-08-11 14:29:54 -04:00			`<meta property=og:type content=og:website>`
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`<meta property=og:title content="$title">`
			`<meta property=og:site_name content="$title">`
			`<meta property=og:description content="$desc">`
add more details (and the image‼) to rss 2024-08-18 00:22:55 -04:00			`<meta property=og:image content="$url/style/card.png">`
add twitter [etc] card previews 2020-08-11 14:29:54 -04:00			`<meta property=og:url content="$url">`
changed twitter username 2020-09-19 02:13:13 -04:00			`<meta name=twitter:site content=@2_gecs>`
add twitter [etc] card previews 2020-08-11 14:29:54 -04:00			`<meta name=twitter:card content=summary>`

add noai tags i guess 2022-11-12 06:14:42 -05:00			`<meta name=robots content='noai,noimageai'>`

you WOULD type a script 2023-09-06 19:17:21 -04:00			`<script src=/script/gallery.js type=module></script>`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`$nsfwScript`
add scripting for filters 2020-08-03 17:11:15 -04:00
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`<title>$title</title>`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`$nsfwDialog`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00
			`<div class=page>`
			`<header>`
			`<h1>$title</h1>`
style & layout updates 2023-06-21 13:58:01 -04:00			`<a class="right corner" href=rss.xml>rss</a>`
			`<a class="left corner" href=$undir>back</a>`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`</header>`

			`<nav id=filters>`
			`<details id=filters-details>`
			`<summary><h2>filters</h2></summary>`
			`<div>`
			`<h3>show only</h3>`
new buttons and tweaked bg gradients 2022-12-29 21:19:33 -05:00			`<ul id=require class=filterlist>`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`$requireFilters`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`</ul>`

			`<h3>exclude</h3>`
new buttons and tweaked bg gradients 2022-12-29 21:19:33 -05:00			`<ul id=exclude class=filterlist>`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`$excludeFilters`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`</ul>`

add sorting filters by name 2022-11-12 06:13:44 -05:00			`<ul id=filterstuff>`
			`<li><a href=# id=clear>clear</a>`
			`<li><a href=# id=sortalpha>sort by name</a>`
			`<li><a href=# id=sortuses>sort by uses</a>`
			`<li><a href=# id=singles>toggle single-use tags</a>`
			`</ul>`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`</div>`
			`</details>`
			`</nav>`

			`<main>`
use headings & figures for gallery grid instead of a ul 2024-08-21 02:22:28 -04:00			`$items`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`</main>`
			`</div>`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`\|]`
			`where`
group gallery items by year 2020-07-18 05:43:35 -04:00			`items = map (uncurry $ makeYearItems nsfw) infosByYear`
pass index file to gallery/rss (instead of trying to escape the strings inside in make & on the command line) 2020-08-03 20:25:59 -04:00
remove TransformListComp which panics in ghc ≥ 9.6 2024-07-07 10:22:14 -04:00			`infosByYear :: [(Int, [(FilePath, Info)])]`
			`infosByYear = infos &`
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`filter (not . (.unlisted) . snd) &`
remove TransformListComp which panics in ghc ≥ 9.6 2024-07-07 10:22:14 -04:00			`sortOn (Down . compareKeyFor nsfw . snd) &`
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`groupOnKey (\(_, i) -> latestYearFor nsfw i)`
pass index file to gallery/rss (instead of trying to escape the strings inside in make & on the command line) 2020-08-03 20:25:59 -04:00
put link to index in footer of gallery pages 2020-07-23 13:51:53 -04:00			`undir = joinPath (replicate (length (splitPath prefix)) "..")`
pass index file to gallery/rss (instead of trying to escape the strings inside in make & on the command line) 2020-08-03 20:25:59 -04:00
add tags to gallery items 2020-08-03 17:07:59 -04:00			`allTags = infos`
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`& concatMap (map (,1) . tagsFor nsfw . snd)`
add tags to gallery items 2020-08-03 17:07:59 -04:00			`& HashMap.fromListWith (+) & HashMap.toList`
style & layout updates 2023-06-21 13:58:01 -04:00			`& sort`
support initially-hidden tags 2020-08-03 20:27:19 -04:00
			`requireFilters = map (uncurry $ makeFilter "require" mempty) allTags`
			`excludeFilters = map (uncurry $ makeFilter "exclude" hidden) allTags`
group gallery items by year 2020-07-18 05:43:35 -04:00
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`nsfw = filters.nsfw /= NoNsfw`
pass index file to gallery/rss (instead of trying to escape the strings inside in make & on the command line) 2020-08-03 20:25:59 -04:00
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`url = [b\|$root/$prefix\|]`
add twitter [etc] card previews 2020-08-11 14:29:54 -04:00
messing with the nsfw warning 2022-01-03 14:45:55 -05:00			`nsfw' = NsfwWarning.Gallery <$ guard nsfw`
			`nsfwScript = NsfwWarning.script nsfw'`
			`nsfwDialog = NsfwWarning.dialog nsfw'`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00
remove TransformListComp which panics in ghc ≥ 9.6 2024-07-07 10:22:14 -04:00			`-- from @extra@`
			`groupOnKey :: Eq k => (a -> k) -> [a] -> [(k, [a])]`
			`groupOnKey _ [] = []`
			`groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no where`
			`fx = f x`
			`(yes, no) = span (\y -> fx == f y) xs`

support initially-hidden tags 2020-08-03 20:27:19 -04:00			`makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`makeFilter prefix initial tag count = [b\|`
hide tags only used once initially 2021-03-12 23:29:57 -05:00			`<li$hidden>`
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`<input type=checkbox id="$id'" value="$tag"$checked>`
(re-)add tag counts to filter list 2020-09-17 13:12:48 -04:00			`<label for="$id'" data-count=$count>$tag</label>`
add filter elements to page 2020-08-03 17:10:52 -04:00			`\|]`
support initially-hidden tags 2020-08-03 20:27:19 -04:00			`where`
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`id' = [b\|$prefix$&_$tag'\|]`
support initially-hidden tags 2020-08-03 20:27:19 -04:00			`tag' = escId tag`
require $& for whitespace before or after a builder 2024-08-21 01:40:28 -04:00			`checked = if HashSet.member tag initial then [b\|$& checked\|] else ""`
			`hidden = if count <= 1 then [b\|$& hidden\|] else ""`
add filter elements to page 2020-08-03 17:10:52 -04:00
group gallery items by year 2020-07-18 05:43:35 -04:00			`makeYearItems :: Bool -- ^ nsfw`
add support for approx dates 2020-09-25 17:08:44 -04:00			`-> Int -- ^ year`
group gallery items by year 2020-07-18 05:43:35 -04:00			`-> [(FilePath, Info)]`
			`-> Builder`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`makeYearItems nsfw year infos = [b\|`
use headings & figures for gallery grid instead of a ul 2024-08-21 02:22:28 -04:00			`<h2 class="item year-marker" id="marker-$year" aria-label=$year>`
			`$year'`
			`</h2>`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`$items`
group gallery items by year 2020-07-18 05:43:35 -04:00			`\|]`
new style 2020-07-20 16:40:34 -04:00			`where`
			`items = map (uncurry $ makeItem nsfw) infos`
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`year' = show year & foldMap \c -> [b\|<span class=y>$c</span>\|]`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00
add nsfw class to relevant gallery items but only on galleries showing nsfw at all 2020-07-18 05:40:56 -04:00			`makeItem :: Bool -> FilePath -> Info -> Builder`
remove the reindent stuff. it does not matter 2024-08-18 01:37:58 -04:00			`makeItem nsfw file info@(Info {bg}) = [b\|`
use headings & figures for gallery grid instead of a ul 2024-08-21 02:22:28 -04:00			`<figure class="item post$nsfw'" data-year=$year' data-updated="$updated'"`
support updates 2020-09-19 01:51:52 -04:00			`data-tags="$tags'">`
style & layout updates 2023-06-21 13:58:01 -04:00			`<a href="$dir">`
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`<img src="$thumbnail" loading=lazy$bgStyle`
explicit height/width in gallery to placate chromium 2023-06-21 16:38:34 -04:00			`width=200 height=200`
style & layout updates 2023-06-21 13:58:01 -04:00			`title="$tooltip">`
			`</a>`
use headings & figures for gallery grid instead of a ul 2024-08-21 02:22:28 -04:00			`</figure>`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`\|]`
			`where`
use headings & figures for gallery grid instead of a ul 2024-08-21 02:22:28 -04:00			`title = fromMaybe info.title info.galleryTitle`
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`dir = takeDirectory file`
			`thumbnail = getThumb dir info`
require $& for whitespace before or after a builder 2024-08-21 01:40:28 -04:00			`nsfw' = if nsfw && anyNsfw info then [b\|$& nsfw\|] else ""`
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info`
			`date = latestDateFor nsfw info`
			`date' = formatTooltip date`
			`year' = date.year`
			`updated' = if hasUpdatesFor nsfw info then [b\|true\|] else [b\|false\|]`
require $& for whitespace before or after a builder 2024-08-21 01:40:28 -04:00			`bgStyle = case bg of Other col -> [b\|$& style="background: $col"\|]; _ -> ""`
replace OverloadedLabels with OverloadedRecordDot 2024-07-11 16:00:00 -04:00			`tooltip = [b\|$title ($upd$date')\|]`
			`where upd = if hasUpdatesFor nsfw info then "updated " else "" :: Builder`