2020-07-19 11:55:54 -04:00
|
|
|
{-# LANGUAGE TransformListComp #-}
|
2020-07-16 10:07:28 -04:00
|
|
|
module GalleryPage (make) where
|
|
|
|
|
|
|
|
|
|
import Control.Exception
|
2020-08-03 17:07:59 -04:00
|
|
|
import Data.Foldable
|
2020-07-20 16:40:34 -04:00
|
|
|
import Data.Function (on, (&))
|
2020-08-03 17:07:59 -04:00
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
2020-08-03 20:27:19 -04:00
|
|
|
import Data.HashSet (HashSet)
|
|
|
|
|
import qualified Data.HashSet as HashSet
|
2020-08-03 17:07:59 -04:00
|
|
|
import Data.List (intersperse, groupBy, sortOn)
|
2020-07-16 10:07:28 -04:00
|
|
|
import qualified Data.Text.Lazy as Lazy
|
2020-07-23 13:51:53 -04:00
|
|
|
import System.FilePath ((</>), takeDirectory, joinPath, splitPath)
|
2020-07-19 11:55:54 -04:00
|
|
|
import GHC.Exts (Down (..), the)
|
2020-07-16 10:07:28 -04:00
|
|
|
|
|
|
|
|
import BuilderQQ
|
|
|
|
|
import Depend (thumbFile)
|
|
|
|
|
import Info
|
|
|
|
|
|
|
|
|
|
newtype NoThumb = NoThumb FilePath
|
|
|
|
|
deriving stock Eq deriving anyclass Exception
|
|
|
|
|
instance Show NoThumb where show (NoThumb dir) = "no thumbnail for " ++ dir
|
|
|
|
|
|
2020-08-03 20:25:59 -04:00
|
|
|
make :: GalleryInfo -> [(FilePath, Info)] -> Lazy.Text
|
|
|
|
|
make ginfo infos = toLazyText $ make' ginfo infos
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
make' :: GalleryInfo -> [(FilePath, Info)] -> Builder
|
2020-08-03 20:27:19 -04:00
|
|
|
make' (GalleryInfo {title, prefix, filters, hidden}) infos = [b|@0
|
2020-07-16 10:07:28 -04:00
|
|
|
<!DOCTYPE html>
|
|
|
|
|
<html lang=en>
|
|
|
|
|
<meta charset=utf-8>
|
2020-07-21 03:16:05 -04:00
|
|
|
<link rel=stylesheet href=/style/shiny/gallery.css title=shiny>
|
2020-07-19 12:04:40 -04:00
|
|
|
<link rel=alternate href=rss.xml type=application/rss+xml>
|
2020-07-16 10:07:28 -04:00
|
|
|
|
2020-08-03 17:11:15 -04:00
|
|
|
<script async src=/script/gallery.js></script>
|
|
|
|
|
|
2020-07-16 10:07:28 -04:00
|
|
|
<title>$*title</title>
|
|
|
|
|
|
|
|
|
|
<header>
|
|
|
|
|
<h1>$*title</h1>
|
2020-07-19 12:04:40 -04:00
|
|
|
<h2 class="right corner">
|
|
|
|
|
<a href=rss.xml>rss</a>
|
|
|
|
|
</h2>
|
2020-07-16 10:07:28 -04:00
|
|
|
</header>
|
|
|
|
|
|
2020-08-04 12:22:16 -04:00
|
|
|
<nav id=filters>
|
2020-08-04 12:46:17 -04:00
|
|
|
<details id=filters-details>
|
2020-08-03 17:10:52 -04:00
|
|
|
<summary><h2>filters</h2></summary>
|
|
|
|
|
<div>
|
|
|
|
|
<h3>show only</h3>
|
2020-08-04 12:58:40 -04:00
|
|
|
<ul id=require class="buttonbar bb-choice">
|
2020-08-03 17:10:52 -04:00
|
|
|
$8.requireFilters
|
|
|
|
|
</ul>
|
|
|
|
|
|
|
|
|
|
<h3>exclude</h3>
|
2020-08-04 12:58:40 -04:00
|
|
|
<ul id=exclude class="buttonbar bb-choice">
|
2020-08-03 17:10:52 -04:00
|
|
|
$8.excludeFilters
|
|
|
|
|
</ul>
|
|
|
|
|
|
|
|
|
|
<a href=# id=clear>clear</a>
|
2020-08-04 10:34:18 -04:00
|
|
|
<a href=# id=reset>default</a>
|
2020-08-03 17:10:52 -04:00
|
|
|
</div>
|
|
|
|
|
</details>
|
2020-08-04 12:22:16 -04:00
|
|
|
</nav>
|
2020-08-03 17:10:52 -04:00
|
|
|
|
2020-07-16 10:07:28 -04:00
|
|
|
<main>
|
|
|
|
|
<ul class=grid>
|
|
|
|
|
$4.items
|
|
|
|
|
</ul>
|
|
|
|
|
</main>
|
2020-07-23 13:51:53 -04:00
|
|
|
|
|
|
|
|
<footer>
|
|
|
|
|
<a href=$@undir>all galleries</a>
|
|
|
|
|
</footer>
|
2020-07-16 10:07:28 -04:00
|
|
|
|]
|
|
|
|
|
where
|
2020-07-18 05:43:35 -04:00
|
|
|
items = map (uncurry $ makeYearItems nsfw) infosByYear
|
2020-08-03 20:25:59 -04:00
|
|
|
|
2020-07-18 05:43:35 -04:00
|
|
|
infosByYear =
|
2020-07-19 11:55:54 -04:00
|
|
|
[(the year, infopath) |
|
|
|
|
|
infopath@(_, info) <- infos,
|
|
|
|
|
then sortOn by Down info,
|
|
|
|
|
let year = #year info,
|
|
|
|
|
then group by Down year using groupBy']
|
|
|
|
|
groupBy' f = groupBy ((==) `on` f)
|
2020-08-03 20:25:59 -04:00
|
|
|
|
2020-07-23 13:51:53 -04:00
|
|
|
undir = joinPath (replicate (length (splitPath prefix)) "..")
|
2020-08-03 20:25:59 -04:00
|
|
|
|
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))
|
2020-08-03 20:27:19 -04:00
|
|
|
|
|
|
|
|
requireFilters = map (uncurry $ makeFilter "require" mempty) allTags
|
|
|
|
|
excludeFilters = map (uncurry $ makeFilter "exclude" hidden) allTags
|
2020-07-18 05:43:35 -04:00
|
|
|
|
2020-08-03 20:25:59 -04:00
|
|
|
nsfw = #nsfw filters /= NoNsfw
|
|
|
|
|
|
2020-08-03 20:27:19 -04:00
|
|
|
makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder
|
|
|
|
|
makeFilter prefix initial tag _count = [b|@8
|
2020-08-03 17:10:52 -04:00
|
|
|
<li>
|
2020-08-03 20:27:19 -04:00
|
|
|
<input type=checkbox id="$id'" value="$*tag"$checked>
|
2020-08-03 17:10:52 -04:00
|
|
|
<label for="$id'">$*tag</label>
|
|
|
|
|
|]
|
2020-08-03 20:27:19 -04:00
|
|
|
where
|
|
|
|
|
id' = [b|$*prefix$&_$tag'|]
|
|
|
|
|
tag' = escId tag
|
|
|
|
|
checked = if HashSet.member tag initial then " checked" else ""
|
2020-08-03 17:10:52 -04:00
|
|
|
|
2020-07-18 05:43:35 -04:00
|
|
|
makeYearItems :: Bool -- ^ nsfw
|
|
|
|
|
-> Integer -- ^ year
|
|
|
|
|
-> [(FilePath, Info)]
|
|
|
|
|
-> Builder
|
|
|
|
|
makeYearItems nsfw year infos = [b|@4
|
|
|
|
|
<li class="item year-marker">
|
2020-07-20 16:40:34 -04:00
|
|
|
<span class=year-text>$year'</span>
|
2020-07-18 05:43:35 -04:00
|
|
|
$4.items
|
|
|
|
|
|]
|
2020-07-20 16:40:34 -04:00
|
|
|
where
|
|
|
|
|
items = map (uncurry $ makeItem nsfw) infos
|
|
|
|
|
year' = show year & foldMap \c -> [b|<span class=y>$'c</span>|]
|
2020-07-16 10:07:28 -04:00
|
|
|
|
2020-07-18 05:40:56 -04:00
|
|
|
makeItem :: Bool -> FilePath -> Info -> Builder
|
2020-07-19 11:58:19 -04:00
|
|
|
makeItem nsfw file info@(Info {title}) = [b|@4
|
2020-08-03 17:07:59 -04:00
|
|
|
<li class="item post$nsfw'" data-tags="$tags'">
|
2020-07-16 10:07:28 -04:00
|
|
|
<figure>
|
|
|
|
|
<a href="$@dir">
|
|
|
|
|
<img src="$@thumb">
|
|
|
|
|
</a>
|
2020-07-19 11:58:19 -04:00
|
|
|
<figcaption>$*title</figcaption>
|
2020-07-16 10:07:28 -04:00
|
|
|
</figure>
|
|
|
|
|
|]
|
|
|
|
|
where
|
|
|
|
|
dir = takeDirectory file
|
|
|
|
|
thumb = maybe (throw $ NoThumb dir) (\t -> dir </> thumbFile t) $ #thumb info
|
2020-07-20 16:40:34 -04:00
|
|
|
nsfw' = if nsfw && #anyNsfw info then " nsfw" else ""
|
2020-08-03 17:07:59 -04:00
|
|
|
tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info
|
