gallery/make-pages/SinglePage.hs

148 lines
4.5 KiB
Haskell
Raw Normal View History

2020-07-09 00:20:09 -04:00
module SinglePage (make) where
2020-07-07 23:28:09 -04:00
import Info hiding (Text)
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)
import Data.Maybe (fromMaybe)
2020-07-07 23:28:09 -04:00
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)"
2020-07-07 23:28:09 -04:00
make :: Bool -> Info -> Lazy.Text
make includeNsfw = toLazyText . make' includeNsfw
2020-07-07 23:28:09 -04:00
make' :: Bool -> Info -> Builder
2020-07-11 23:42:31 -04:00
make' includeNsfw (Info {date, title, tags, nsfwTags,
description, images, links}) =
2020-07-07 23:28:09 -04:00
"<!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") <>
2020-07-07 23:28:09 -04:00
"<header>\n" <>
ifJust title (\t -> " <h1>" <> esc t <> "</h1>\n") <>
2020-07-07 23:28:09 -04:00
" <h2 class=date>" <> formatDate date <> "</h2>\n" <>
buttonBar title' includeNsfw images <>
2020-07-07 23:28:09 -04:00
"</header>\n\n" <>
"<main>\n" <>
" <img id=it src=\"" <> path0 <> "\">\n" <>
ifJust description (\d ->
" <div class=desc>\n" <>
" <h2>description</h2>\n" <>
indent 4 d <>
" </div>\n") <>
2020-07-11 23:42:31 -04:00
makeTags includeNsfw tags nsfwTags <>
extLinks includeNsfw links <>
2020-07-07 23:28:09 -04:00
"</main>\n\n" <>
"<nav class=back>\n" <>
" <a href=../>back to gallery</a>\n" <>
"</nav>\n"
where
path0' = let Image {path} = head images in path
path0 = fromText path0'
title' = fromMaybe path0' title
2020-07-07 23:28:09 -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
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
2020-07-07 23:28:09 -04:00
altButton :: Int -> Image -> Builder
2020-07-09 00:18:53 -04:00
altButton i (Image {label, path, nsfw}) =
2020-07-09 00:19:19 -04:00
" <li" <> nsfwClass <> ">\n" <>
2020-07-07 23:28:09 -04:00
" <input type=radio " <> checked <> "id=\"" <> idLabel <> "\" " <>
"name=variant autocomplete=off\n" <>
" value=\"" <> fromText path <> "\">\n" <>
" <label for=\"" <> idLabel <> "\">" <> fromText label <> "</label>\n"
where
2020-07-09 00:19:19 -04:00
nsfwClass = if nsfw then " class=nsfw" else ""
2020-07-07 23:28:09 -04:00
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 ' '
2020-07-11 23:42:31 -04:00
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"
2020-07-07 23:28:09 -04:00
extLink :: Link -> Builder
2020-07-09 00:18:53 -04:00
extLink (Link {title, url}) =
2020-07-07 23:28:09 -04:00
" <li>\n" <>
" <a href=\"" <> fromText url <> "\">\n" <>
" " <> fromText title <> "\n" <>
" </a>\n"