gallery/make-pages/ImagePage.hs

96 lines
2.7 KiB
Haskell
Raw Normal View History

2020-07-07 23:28:09 -04:00
{-# OPTIONS_GHC -fdefer-typed-holes #-}
module ImagePage
(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 :: Info -> Lazy.Text
make = toLazyText . make'
make' :: Info -> Builder
2020-07-09 00:18:53 -04:00
make' (Info {date, title, tags, 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" <>
"<title>" <> esc title <> "</title>\n\n" <>
"<header>\n" <>
" <h1>" <> esc title <> "</h1>\n" <>
" <h2 class=date>" <> formatDate date <> "</h2>\n" <>
" <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" <>
"</header>\n\n" <>
"<main>\n" <>
" <img id=it src=\"" <> path0 <> "\">\n" <>
" <section id=description>\n" <>
indent 4 description <>
" </section>\n\n" <>
" <h2>links</h2>\n" <>
" <ul>\n" <>
foldMap extLink links <>
" </ul>\n" <>
"</main>\n\n" <>
"<nav class=back>\n" <>
" <a href=../>back to gallery</a>\n" <>
"</nav>\n"
where
2020-07-09 00:18:53 -04:00
path0 = let Image {path} = Vector.head images in fromText path
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"
altButton :: Int -> Image -> Builder
2020-07-09 00:18:53 -04:00
altButton i (Image {label, path, nsfw}) =
2020-07-07 23:28:09 -04:00
" <li>\n" <>
" <input type=radio " <> checked <> "id=\"" <> idLabel <> "\" " <>
"name=variant autocomplete=off\n" <>
" value=\"" <> fromText path <> "\">\n" <>
" <label for=\"" <> idLabel <> "\">" <> fromText label <> "</label>\n"
where
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 ' '
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"