2020-07-09 00:20:09 -04:00
|
|
|
module SinglePage (make) where
|
2020-07-07 23:28:09 -04:00
|
|
|
|
2020-07-13 02:33:27 -04:00
|
|
|
import Records ()
|
2020-07-07 23:28:09 -04:00
|
|
|
import Info hiding (Text)
|
2020-07-15 15:31:46 -04:00
|
|
|
import BuilderQQ
|
2020-07-12 22:01:31 -04:00
|
|
|
|
2020-07-11 23:40:14 -04:00
|
|
|
import Control.Exception
|
2020-07-07 23:28:09 -04:00
|
|
|
import qualified Data.Text as Strict
|
|
|
|
|
import qualified Data.Text.Lazy as Lazy
|
|
|
|
|
import Data.Text.Lazy.Builder
|
|
|
|
|
import Data.Time (formatTime, defaultTimeLocale)
|
2020-07-11 23:40:14 -04:00
|
|
|
import Data.Maybe (fromMaybe)
|
2020-07-07 23:28:09 -04:00
|
|
|
import qualified Data.Char as Char
|
2020-07-11 23:40:14 -04:00
|
|
|
import qualified Data.List as List
|
|
|
|
|
|
|
|
|
|
|
2020-07-12 23:02:16 -04:00
|
|
|
-- | e.g. only nsfw images are present for a non-nsfw page
|
2020-07-11 23:40:14 -04:00
|
|
|
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)"
|
2020-07-07 23:28:09 -04:00
|
|
|
|
|
|
|
|
|
2020-07-09 15:48:29 -04:00
|
|
|
make :: Bool -> Info -> Lazy.Text
|
2020-07-13 02:32:59 -04:00
|
|
|
make nsfw = toLazyText . make' nsfw
|
2020-07-07 23:28:09 -04:00
|
|
|
|
2020-07-09 15:48:29 -04:00
|
|
|
make' :: Bool -> Info -> Builder
|
2020-07-14 00:51:46 -04:00
|
|
|
make' nsfw (Info {date, title, artist, tags, nsfwTags,
|
2020-07-13 02:32:59 -04:00
|
|
|
description, images, links}) = [b|@0
|
2020-07-12 22:01:31 -04:00
|
|
|
<!DOCTYPE html>
|
|
|
|
|
<html lang=en>
|
|
|
|
|
<meta charset=utf-8>
|
|
|
|
|
$titleTag
|
|
|
|
|
|
|
|
|
|
<header>
|
|
|
|
|
$titleHeader
|
2020-07-14 00:51:46 -04:00
|
|
|
$artistTag
|
2020-07-12 22:01:31 -04:00
|
|
|
<h2 class=date>$formattedDate</date>
|
|
|
|
|
$buttonBar
|
|
|
|
|
</header>
|
|
|
|
|
|
|
|
|
|
<main>
|
2020-07-15 05:35:32 -04:00
|
|
|
<img id=it src="$@path0">
|
2020-07-12 22:01:31 -04:00
|
|
|
|
|
|
|
|
$descSection
|
|
|
|
|
|
|
|
|
|
$tagsList
|
|
|
|
|
|
|
|
|
|
$linksList
|
|
|
|
|
</main>
|
|
|
|
|
|
|
|
|
|
<footer>
|
|
|
|
|
<nav class=back>
|
|
|
|
|
<a href=../>back to gallery</a>
|
|
|
|
|
</nav>
|
|
|
|
|
</footer>
|
|
|
|
|
|]
|
|
|
|
|
where
|
2020-07-13 02:33:27 -04:00
|
|
|
titleTag = ifJust title \t -> [b|<title>$*t</title>|]
|
2020-07-12 22:01:31 -04:00
|
|
|
titleHeader = ifJust title \t -> [b|<h1>$*t</h1>|]
|
2020-07-13 02:33:27 -04:00
|
|
|
|
2020-07-14 00:51:46 -04:00
|
|
|
artistTag = ifJust artist makeArtist
|
|
|
|
|
|
2020-07-12 22:01:31 -04:00
|
|
|
formattedDate = formatDate date
|
2020-07-13 02:33:27 -04:00
|
|
|
|
2020-07-15 05:35:32 -04:00
|
|
|
buttonBar = makeButtonBar (fromMaybe (Strict.pack path0) title) nsfw images
|
2020-07-13 02:33:27 -04:00
|
|
|
path0 = #path $ head images
|
2020-07-12 22:01:31 -04:00
|
|
|
|
|
|
|
|
descSection = ifJust description makeDesc
|
2020-07-13 02:32:59 -04:00
|
|
|
tagsList = makeTags nsfw tags nsfwTags
|
|
|
|
|
linksList = extLinks nsfw links
|
2020-07-12 22:01:31 -04:00
|
|
|
|
2020-07-14 00:51:46 -04:00
|
|
|
makeArtist :: Artist -> Builder
|
|
|
|
|
makeArtist (Artist {name, url}) =
|
|
|
|
|
[b|<h2 class=artist>by $artistLink</h2>|]
|
|
|
|
|
where
|
|
|
|
|
artistLink = case url of
|
|
|
|
|
Just u -> [b|<a href="$*u">$*name</a>|]
|
|
|
|
|
Nothing -> [b|$*name|]
|
|
|
|
|
|
2020-07-12 22:01:31 -04:00
|
|
|
makeDesc :: Strict.Text -> Builder
|
|
|
|
|
makeDesc desc = [b|@2
|
|
|
|
|
<div class=desc>
|
|
|
|
|
<h2>description</h2>
|
|
|
|
|
$4*desc
|
|
|
|
|
</div>
|
|
|
|
|
|]
|
2020-07-07 23:28:09 -04:00
|
|
|
|
2020-07-11 23:40:14 -04:00
|
|
|
ifJust :: Monoid b => Maybe a -> (a -> b) -> b
|
|
|
|
|
ifJust x f = maybe mempty f x
|
2020-07-07 23:28:09 -04:00
|
|
|
|
|
|
|
|
formatDate :: Day -> Builder
|
|
|
|
|
formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
|
|
|
|
|
|
2020-07-12 22:01:31 -04:00
|
|
|
makeButtonBar :: Strict.Text -> Bool -> [Image] -> Builder
|
2020-07-13 02:32:59 -04:00
|
|
|
makeButtonBar title nsfw allImages =
|
2020-07-12 22:01:31 -04:00
|
|
|
case length images of
|
|
|
|
|
0 -> throw $ NoEligibleImages title
|
|
|
|
|
1 -> ""
|
|
|
|
|
_ -> [b|@2
|
|
|
|
|
<nav id=variants class=buttonbar>
|
|
|
|
|
<h2>alts</h2>
|
|
|
|
|
<ul id=variantlist>
|
|
|
|
|
$6.alts
|
|
|
|
|
</ul>
|
|
|
|
|
</nav>
|
|
|
|
|
|]
|
2020-07-11 23:40:14 -04:00
|
|
|
where
|
2020-07-13 02:32:59 -04:00
|
|
|
images | nsfw = allImages
|
2020-07-13 02:33:27 -04:00
|
|
|
| otherwise = filter #sfw allImages
|
|
|
|
|
alts = map (uncurry altButton) $ zip [0..] images
|
2020-07-09 15:48:29 -04:00
|
|
|
|
2020-07-07 23:28:09 -04:00
|
|
|
altButton :: Int -> Image -> Builder
|
2020-07-12 22:01:31 -04:00
|
|
|
altButton i (Image {label, path, nsfw}) = [b|@6
|
|
|
|
|
<li$nsfwClass>
|
|
|
|
|
<input type=radio$checked id="$idLabel" name=variant
|
2020-07-15 05:35:32 -04:00
|
|
|
autocomplete=off value="$@path">
|
2020-07-12 22:01:31 -04:00
|
|
|
<label for="$idLabel">$*label</label>
|
|
|
|
|
|]
|
2020-07-07 23:28:09 -04:00
|
|
|
where
|
2020-07-09 00:19:19 -04:00
|
|
|
nsfwClass = if nsfw then " class=nsfw" else ""
|
2020-07-12 22:01:31 -04:00
|
|
|
checked = if i == 0 then " checked" else ""
|
2020-07-07 23:28:09 -04:00
|
|
|
idLabel = escId label
|
|
|
|
|
|
|
|
|
|
escId :: Strict.Text -> Builder
|
|
|
|
|
escId = foldMap esc1 . Strict.unpack where
|
|
|
|
|
esc1 c
|
|
|
|
|
| Char.isSpace c = ""
|
|
|
|
|
| c < 'ÿ' && not (Char.isAlphaNum c || c == '-') = "_"
|
|
|
|
|
| otherwise = singleton c
|
|
|
|
|
|
2020-07-11 23:42:31 -04:00
|
|
|
makeTags :: Bool -> [Strict.Text] -> [Strict.Text] -> Builder
|
2020-07-13 02:32:59 -04:00
|
|
|
makeTags nsfw sfwTags nsfwTags =
|
2020-07-12 22:01:31 -04:00
|
|
|
if null tags then "" else [b|@2
|
|
|
|
|
<div class=tags>
|
|
|
|
|
<h2>tags</h2>
|
|
|
|
|
<ul>
|
|
|
|
|
$6.tagList
|
|
|
|
|
</ul>
|
|
|
|
|
</div>
|
|
|
|
|
|]
|
2020-07-11 23:42:31 -04:00
|
|
|
where
|
2020-07-12 22:01:31 -04:00
|
|
|
tagList = map makeTag tags
|
|
|
|
|
makeTag t = [b|<li>$*t|]
|
2020-07-13 02:32:59 -04:00
|
|
|
tags = List.nub $ if nsfw then sfwTags else sfwTags <> nsfwTags
|
2020-07-11 23:42:31 -04:00
|
|
|
|
2020-07-11 23:40:14 -04:00
|
|
|
extLinks :: Bool -> [Link] -> Builder
|
2020-07-13 02:32:59 -04:00
|
|
|
extLinks nsfw allLinks =
|
2020-07-12 22:01:31 -04:00
|
|
|
if null links then "" else [b|@2
|
|
|
|
|
<div class=links>
|
|
|
|
|
<h2>links</h2>
|
|
|
|
|
<ul>
|
|
|
|
|
$6.linkList
|
|
|
|
|
</ul>
|
|
|
|
|
</div>
|
|
|
|
|
|]
|
|
|
|
|
where
|
2020-07-13 02:33:27 -04:00
|
|
|
links = if nsfw then allLinks else filter #sfw allLinks
|
2020-07-12 22:01:31 -04:00
|
|
|
linkList = map extLink links
|
2020-07-09 15:48:29 -04:00
|
|
|
|
2020-07-07 23:28:09 -04:00
|
|
|
extLink :: Link -> Builder
|
2020-07-12 22:01:31 -04:00
|
|
|
extLink (Link {title, url}) = [b|@6
|
|
|
|
|
<li>
|
|
|
|
|
<a href="$*url">
|
|
|
|
|
$*title
|
|
|
|
|
</a>
|
|
|
|
|
|]
|
