150 lines
4.6 KiB
Haskell
150 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 '<' = "<"
|
|
esc1 '>' = ">"
|
|
esc1 '&' = "&"
|
|
esc1 '"' = """
|
|
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"
|