hablo/src/DOM.hs

109 lines
3.5 KiB
Haskell
Raw Normal View History

2019-01-27 21:41:21 +01:00
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module DOM (
page
2019-01-27 21:41:21 +01:00
) where
import Article (Article(..))
2019-02-15 14:13:43 +01:00
import qualified Article (preview)
import ArticlesList (
ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
)
import Blog (Blog(..), Path(..), Skin(..), URL(..))
import qualified Blog (get)
import Blog.Wording (render)
import Control.Monad.Reader (ReaderT, asks)
import qualified Data.Map as Map (keys)
import Data.Text (pack, empty)
import DOM.Card (HasCard)
import qualified DOM.Card as Card (make)
import Files (absoluteLink)
2020-03-25 19:47:28 +01:00
import Lucid (
HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
, title_, toHtml, toHtmlRaw, type_, ul_
)
import Prelude hiding (head, lookup)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))
type HtmlGenerator = HtmlT (ReaderT Blog IO)
2019-01-27 21:41:21 +01:00
class HasCard a => Page a where
content :: a -> HtmlGenerator ()
instance Page Article where
2019-02-15 14:13:43 +01:00
content = article True
instance Page ArticlesList where
content al@(ArticlesList {full}) = do
2019-02-15 14:13:43 +01:00
preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
2020-03-25 19:47:28 +01:00
h2_ . toHtml =<< description al
ul_ $ do
asks hasRSS >>= rssLink
li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
2019-02-15 14:13:43 +01:00
div_ [class_ "articles"] (
mapM_ (article False . preview) =<< getArticles al
2019-02-15 14:13:43 +01:00
)
2019-02-17 19:52:28 +01:00
where
link = render (if full then "latestLink" else "allLink") []
otherLink = Blog.get $wording.$link.$toHtml
rssLink :: Bool -> HtmlGenerator ()
rssLink True = do
(text, title) <- rssLinkTexts al
li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
rssLink False = return ()
2019-02-15 14:13:43 +01:00
article :: Bool -> Article -> HtmlGenerator ()
article raw (Article {key, body, Article.title}) = do
url <- absoluteLink . (</> key <.> extension) <$> (Blog.get $path.$articlesPath)
article_ [id_ $ pack key] (do
2019-02-15 14:13:43 +01:00
header_ (do
a_ [href_ $ pack url] . h1_ $ toHtml title
2019-02-15 14:13:43 +01:00
)
pre_ . toHtml $ unlines body
)
where extension = if raw then "md" else "html"
tag :: String -> HtmlGenerator ()
tag name = li_ (
a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
)
defaultBanner :: HtmlGenerator ()
defaultBanner = do
div_ [id_ "header"] (
a_ [href_ "/"] (
h1_ . toHtml =<< Blog.get name
)
)
2019-01-27 21:41:21 +01:00
faviconLink :: FilePath -> HtmlGenerator ()
faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"]
optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
optional = maybe (return ())
page :: Page a => a -> HtmlGenerator ()
page aPage =
2019-01-27 21:41:21 +01:00
doctypehtml_ (do
head_ (do
meta_ [charset_ "utf-8"]
title_ . toHtml =<< Blog.get name
2019-02-15 14:13:43 +01:00
script_ [src_ "/js/unit.js"] empty
script_ [src_ "/js/remarkable.min.js"] empty
script_ [src_ "/js/hablo.js"] empty
optional faviconLink =<< (Blog.get $skin.$favicon)
2020-03-25 19:47:28 +01:00
optional (Card.make aPage) =<< (Blog.get $urls.$cards)
(Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
2019-01-27 21:41:21 +01:00
)
body_ (do
2019-02-17 19:52:28 +01:00
maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
2019-01-27 21:41:21 +01:00
div_ [id_ "navigator"] (do
h2_ =<< (Blog.get $wording.$(render "tagsList" []).$toHtml)
ul_ . mapM_ tag . Map.keys =<< Blog.get tags
2019-01-27 21:41:21 +01:00
)
div_ [id_ "contents"] $ content aPage
2019-01-27 21:41:21 +01:00
)
)