112 lines
3.4 KiB
Haskell
112 lines
3.4 KiB
Haskell
module SinglePage (make) where
|
|
|
|
import Info hiding (Text)
|
|
import qualified Data.Text as Strict
|
|
import qualified Data.Text.Lazy as Lazy
|
|
import Data.Text.Lazy.Builder
|
|
import Data.Time (formatTime, defaultTimeLocale)
|
|
import qualified Data.Char as Char
|
|
import qualified Data.Vector as Vector
|
|
|
|
|
|
make :: Bool -> Info -> Lazy.Text
|
|
make includeNsfw = toLazyText . make' includeNsfw
|
|
|
|
make' :: Bool -> Info -> Builder
|
|
make' includeNsfw (Info {date, title, tags, description, images, links}) =
|
|
"<!DOCTYPE html>\n" <>
|
|
"<html lang=en>\n" <>
|
|
"<meta charset=utf-8>\n" <>
|
|
"<link href=single.css rel=stylesheet>\n\n" <>
|
|
"<title>" <> esc title <> "</title>\n\n" <>
|
|
"<header>\n" <>
|
|
" <h1>" <> esc title <> "</h1>\n" <>
|
|
" <h2 class=date>" <> formatDate date <> "</h2>\n" <>
|
|
buttonBar includeNsfw images <>
|
|
"</header>\n\n" <>
|
|
"<main>\n" <>
|
|
" <img id=it src=\"" <> path0 <> "\">\n" <>
|
|
" <section id=description>\n" <>
|
|
indent 4 description <>
|
|
" </section>\n\n" <>
|
|
extLinks includeNsfw links <>
|
|
"</main>\n\n" <>
|
|
"<nav class=back>\n" <>
|
|
" <a href=../>back to gallery</a>\n" <>
|
|
"</nav>\n"
|
|
where
|
|
path0 = let Image {path} = Vector.head images in fromText path
|
|
|
|
|
|
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 :: Bool -> Vector Image -> Builder
|
|
buttonBar includeNsfw images =
|
|
let images' = if includeNsfw then images
|
|
else Vector.filter (\Image {nsfw} -> not nsfw) images in
|
|
if null images' then
|
|
error "not including nsfw but there are no sfw images!"
|
|
else if length images' == 1 then
|
|
mempty
|
|
else
|
|
" <nav id=variants class=buttonbar>\n" <>
|
|
" <h2>alts</h2>\n" <>
|
|
" <ul id=variantlist>\n" <>
|
|
Vector.ifoldl' (\b i im -> b <> altButton i im) mempty images' <>
|
|
" </ul>\n" <>
|
|
" </nav>\n"
|
|
|
|
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 ' '
|
|
|
|
extLinks :: Bool -> Vector Link -> Builder
|
|
extLinks includeNsfw links =
|
|
let links' =
|
|
if includeNsfw then links
|
|
else Vector.filter (\Link {nsfw} -> not nsfw) links in
|
|
if null links' then mempty else
|
|
" <h2>links</h2>\n" <>
|
|
" <ul>\n" <>
|
|
foldMap extLink links' <>
|
|
" </ul>\n"
|
|
|
|
extLink :: Link -> Builder
|
|
extLink (Link {title, url}) =
|
|
" <li>\n" <>
|
|
" <a href=\"" <> fromText url <> "\">\n" <>
|
|
" " <> fromText title <> "\n" <>
|
|
" </a>\n"
|