gallery/make-pages/SinglePage.hs

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 '<' = "&lt;"
esc1 '>' = "&gt;"
esc1 '&' = "&amp;"
esc1 '"' = "&quot;"
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"