gallery/make-pages/SinglePage.hs

149 lines
4.6 KiB
Haskell

module SinglePage (make) where
import Info hiding (Text)
import Control.Exception
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder
import Data.Time (formatTime, defaultTimeLocale)
import Data.Maybe (fromMaybe)
import qualified Data.Char as Char
import qualified Data.List as List
-- | only nsfw images are present for a non-nsfw page
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)"
make :: Bool -> Info -> Lazy.Text
make includeNsfw = toLazyText . make' includeNsfw
make' :: Bool -> Info -> Builder
make' includeNsfw (Info {date, title, tags, nsfwTags,
description, images, links}) =
"<!DOCTYPE html>\n" <>
"<html lang=en>\n" <>
"<meta charset=utf-8>\n" <>
"<link href=single.css rel=stylesheet>\n\n" <>
ifJust title (\t -> "<title>" <> esc t <> "</title>\n\n") <>
"<header>\n" <>
ifJust title (\t -> " <h1>" <> esc t <> "</h1>\n") <>
" <h2 class=date>" <> formatDate date <> "</h2>\n" <>
buttonBar title' includeNsfw images <>
"</header>\n\n" <>
"<main>\n" <>
" <img id=it src=\"" <> path0 <> "\">\n\n" <>
ifJust description (\d ->
" <div class=desc>\n" <>
" <h2>description</h2>\n" <>
indent 4 d <>
" </div>\n") <> "\n" <>
makeTags includeNsfw tags nsfwTags <>
extLinks includeNsfw links <>
"</main>\n\n" <>
"<footer>\n" <>
" <nav class=back>\n" <>
" <a href=../>back to gallery</a>\n" <>
" </nav>\n" <>
"</footer>\n"
where
path0' = let Image {path} = head images in path
path0 = fromText path0'
title' = fromMaybe path0' title
ifJust :: Monoid b => Maybe a -> (a -> b) -> b
ifJust x f = maybe mempty f x
esc :: Strict.Text -> Builder
esc = foldMap esc1 . Strict.unpack where
esc1 '<' = "&lt;"
esc1 '>' = "&gt;"
esc1 '&' = "&amp;"
esc1 '"' = "&quot;"
esc1 '\'' = "&squot;"
esc1 c = singleton c
formatDate :: Day -> Builder
formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
buttonBar :: Strict.Text -> Bool -> [Image] -> Builder
buttonBar title includeNsfw allImages =
if null images then
throw $ NoEligibleImages title
else if length images == 1 then
mempty
else
" <nav id=variants class=buttonbar>\n" <>
" <h2>alts</h2>\n" <>
" <ul id=variantlist>\n" <>
List.foldl' (\b (i, im) -> b <> altButton i im) mempty iimages <>
" </ul>\n" <>
" </nav>\n"
where
images | includeNsfw = allImages
| otherwise = filter (\Image {nsfw} -> not nsfw) allImages
iimages = zip [0..] images
altButton :: Int -> Image -> Builder
altButton i (Image {label, path, nsfw}) =
" <li" <> nsfwClass <> ">\n" <>
" <input type=radio " <> checked <> "id=\"" <> idLabel <> "\" " <>
"name=variant autocomplete=off\n" <>
" value=\"" <> fromText path <> "\">\n" <>
" <label for=\"" <> idLabel <> "\">" <> fromText label <> "</label>\n"
where
nsfwClass = if nsfw then " class=nsfw" else ""
checked = if i == 0 then "checked " else ""
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
indent :: Int -> Strict.Text -> Builder
indent n txt = spaces <> go (Strict.unpack txt) where
go "" = mempty
go "\n" = "\n"
go ('\n':cs) = singleton '\n' <> spaces <> go cs
go (c:cs) = singleton c <> go cs
spaces = fromString $ replicate n ' '
makeTags :: Bool -> [Strict.Text] -> [Strict.Text] -> Builder
makeTags includeNsfw sfwTags nsfwTags =
if null tags then mempty else
" <div class=tags>\n" <>
" <h2>tags</h2>\n" <>
" <ul>\n" <> foldMap makeTag tags <> " </ul>\n" <>
" </div>\n\n"
where
tags = List.nub $ if includeNsfw then sfwTags else sfwTags <> nsfwTags
makeTag t = " <li>" <> fromText t <> "\n"
extLinks :: Bool -> [Link] -> Builder
extLinks includeNsfw links =
let links' =
if includeNsfw then links
else filter (\Link {nsfw} -> not nsfw) links in
if null links' then mempty else
" <div class=links>\n" <>
" <h2>links</h2>\n" <>
" <ul>\n" <>
foldMap extLink links' <>
" </ul>\n" <>
" </div>\n"
extLink :: Link -> Builder
extLink (Link {title, url}) =
" <li>\n" <>
" <a href=\"" <> fromText url <> "\">\n" <>
" " <> fromText title <> "\n" <>
" </a>\n"