gallery/make-pages/GalleryPage.hs

{-# LANGUAGE TransformListComp #-}
module GalleryPage (make) where

import BuilderQQ
import Date
import Info
import qualified NsfwWarning

import Control.Monad
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, sortBy, sortOn)
import Data.Maybe
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>
    $0.nsfwScript

    <title>$title</title>

    $0.nsfwDialog

    <div class=page>
      <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">
              $10.requireFilters
            </ul>

            <h3>exclude</h3>
            <ul id=exclude class="buttonbar bb-choice">
              $10.excludeFilters
            </ul>

            <a href=# id=clear>clear</a>
            <a href=# id=singles>toggle single-use tags</a>
          </div>
        </details>
      </nav>

      <main>
        <ul class=grid>
          $6.items
        </ul>
      </main>

      <footer>
        <a href=$undir>all galleries</a>
      </footer>
    </div>
  |]
 where
  items = map (uncurry $ makeYearItems nsfw) infosByYear

  infosByYear =
    [(the year, infopath) |
      infopath@(_, info) <- infos,
      not $ #unlisted info,
      then sortInfo by info,
      let year = #latestYear info nsfw,
      then group by Down year using groupBy']
  sortInfo f = sortBy $ flip (compareFor nsfw `on` f)
  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"

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

makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder
makeFilter prefix initial tag count = [b|@0
    <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|@0
    <li class="item year-marker" id="marker-$year">
      <span class=year-text>$year'</span>
    $0.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|@0
    <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
  title    = fromMaybe (#title info) $ #galleryTitle info
  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 nsfw
  date'    = formatShort date
  year'    = #year date
  updated' = if #updated info nsfw then [b|true|] else [b|false|]
  bgStyle  = ifJust bg \col -> [b| style="background: $col"|]
improve sorting 2020-07-19 11:55:54 -04:00			`{-# LANGUAGE TransformListComp #-}`
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`
new style 2020-07-20 16:40:34 -04:00			`import Data.Function (on, (&))`
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`
allow updates to be marked nsfw-only 2020-11-16 17:30:56 -05:00			`import Data.List (intersperse, groupBy, sortBy, sortOn)`
allow separate title in gallery e.g. to avoid spoilers 2022-02-27 17:48:35 -05:00			`import Data.Maybe`
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)`
improve sorting 2020-07-19 11:55:54 -04:00			`import GHC.Exts (Down (..), the)`
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`
			`make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b\|@0`
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">`
			`<meta property=og:image content="$url/$imagepath0">`
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>`

use DOMContentLoaded 2020-08-04 13:14:12 -04:00			`<script src=/script/gallery.js></script>`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`$0.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
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`$0.nsfwDialog`

			`<div class=page>`
			`<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">`
			`$10.requireFilters`
			`</ul>`

			`<h3>exclude</h3>`
			`<ul id=exclude class="buttonbar bb-choice">`
			`$10.excludeFilters`
			`</ul>`

			`<a href=# id=clear>clear</a>`
			`<a href=# id=singles>toggle single-use tags</a>`
			`</div>`
			`</details>`
			`</nav>`

			`<main>`
			`<ul class=grid>`
			`$6.items`
			`</ul>`
			`</main>`

			`<footer>`
			`<a href=$undir>all galleries</a>`
			`</footer>`
			`</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
group gallery items by year 2020-07-18 05:43:35 -04:00			`infosByYear =`
improve sorting 2020-07-19 11:55:54 -04:00			`[(the year, infopath) \|`
			`infopath@(_, info) <- infos,`
Add 'unlisted' key unlisted posts will still be put in the normal place but not added to the gallery or rss feed 2021-10-02 17:00:33 -04:00			`not $ #unlisted info,`
allow updates to be marked nsfw-only 2020-11-16 17:30:56 -05:00			`then sortInfo by info,`
			`let year = #latestYear info nsfw,`
improve sorting 2020-07-19 11:55:54 -04:00			`then group by Down year using groupBy']`
allow updates to be marked nsfw-only 2020-11-16 17:30:56 -05:00			sortInfo f = sortBy $ flip (compareFor nsfw `on` f)
improve sorting 2020-07-19 11:55:54 -04:00			groupBy' f = groupBy ((==) `on` f)
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`
			`& concatMap (map (,1) . tagsFor nsfw . #second)`
			`& HashMap.fromListWith (+) & HashMap.toList`
			`& sortOn (\(tag, count) -> (Down count, tag))`
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
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			`nsfw = #nsfw filters /= NoNsfw`

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			`imagepath0`
			`\| (_, (p0, i0) : _) : _ <- infosByYear = getThumb (takeDirectory p0) i0`
			`\| otherwise = "/style/card.png"`

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
support initially-hidden tags 2020-08-03 20:27:19 -04:00			`makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`makeFilter prefix initial tag count = [b\|@0`
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`
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`checked = if HashSet.member tag initial then [b\| checked\|] else ""`
hide tags only used once initially 2021-03-12 23:29:57 -05:00			`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`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`makeYearItems nsfw year infos = [b\|@0`
hide year headings when all items are hidden fixes #7 2020-09-26 19:36:20 -04:00			`<li class="item year-marker" id="marker-$year">`
new style 2020-07-20 16:40:34 -04:00			`<span class=year-text>$year'</span>`
add nsfw warning dialog 2020-10-06 16:07:39 -04:00			`$0.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`
allow separate title in gallery e.g. to avoid spoilers 2022-02-27 17:48:35 -05:00			`makeItem nsfw file info@(Info {bg}) = [b\|@0`
hide year headings when all items are hidden fixes #7 2020-09-26 19:36:20 -04:00			`<li class="item post$nsfw'" data-date="$date'" data-year=$year'`
			`data-updated="$updated'"`
support updates 2020-09-19 01:51:52 -04:00			`data-tags="$tags'">`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`<figure>`
use class instead of twigils for builder 2020-08-30 13:13:40 -04:00			`<a href="$dir">`
add loading=lazy 2020-09-29 13:58:54 -04:00			`<img src="$thumb" loading=lazy$bgStyle>`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`</a>`
support updates 2020-09-19 01:51:52 -04:00			`<figcaption>`
			`<span class=date>$date'</span>`
			`<span class=title>$title</span>`
			`</figcaption>`
a lot of stuff sorry 2020-07-16 10:07:28 -04:00			`</figure>`
			`\|]`
			`where`
allow separate title in gallery e.g. to avoid spoilers 2022-02-27 17:48:35 -05:00			`title = fromMaybe (#title info) $ #galleryTitle info`
support updates 2020-09-19 01:51:52 -04:00			`dir = takeDirectory file`
			`thumb = getThumb dir info`
			`nsfw' = if nsfw && #anyNsfw info then [b\| nsfw\|] else ""`
			`tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info`
allow updates to be marked nsfw-only 2020-11-16 17:30:56 -05:00			`date = #latestDate info nsfw`
hide year headings when all items are hidden fixes #7 2020-09-26 19:36:20 -04:00			`date' = formatShort date`
			`year' = #year date`
allow updates to be marked nsfw-only 2020-11-16 17:30:56 -05:00			`updated' = if #updated info nsfw then [b\|true\|] else [b\|false\|]`
support updates 2020-09-19 01:51:52 -04:00			`bgStyle = ifJust bg \col -> [b\| style="background: $col"\|]`