139 lines
4.7 KiB
Haskell
139 lines
4.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module DOM (
|
|
PageType(..)
|
|
, htmlDocument
|
|
) where
|
|
|
|
import Article (Article)
|
|
import qualified Article (preview)
|
|
import ArticlesList (
|
|
ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
|
|
)
|
|
import Blog (Blog(..), Skin(..), URLs(..), template)
|
|
import Blog.URL (localPrefix)
|
|
import qualified Collection (tag)
|
|
import Control.Monad.Reader (ReaderT, asks)
|
|
import Data.Map as Map (Map, toList)
|
|
import Data.Text (Text, pack, empty)
|
|
import DOM.Card (HasCard)
|
|
import qualified DOM.Card as Card (make)
|
|
--import Lucid (
|
|
-- Attribute, 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 Markdown (Markdown(..), MarkdownContent(..))
|
|
import Network.URL (URL)
|
|
import Page (Page)
|
|
import Prelude hiding (div, head, id, lookup)
|
|
import Pretty ((.$))
|
|
import System.FilePath.Posix ((</>), (<.>))
|
|
import Text.Blaze.Html5 as H (
|
|
(!), Html, ToValue(..), body, div, docTypeHtml, h2, head, li, meta, preEscapedText, script, text, title, ul
|
|
)
|
|
import Text.Blaze.Html5.Attributes (
|
|
charset, class_, id, src
|
|
)
|
|
|
|
type HtmlGenerator = ReaderT Blog IO Html
|
|
|
|
class HasCard a => PageType a where
|
|
content :: a -> HtmlGenerator
|
|
pathToRoot :: a -> FilePath
|
|
|
|
instance PageType Article where
|
|
content = mDContent True ".." . getMarkdown
|
|
pathToRoot _ = ".."
|
|
|
|
instance PageType Page where
|
|
content = mDContent True ".." . getMarkdown
|
|
pathToRoot _ = ".."
|
|
|
|
instance PageType ArticlesList where
|
|
content al@(ArticlesList {full}) = do
|
|
preview <- Article.preview <$> (asks $skin.$previewLinesCount)
|
|
h2_ . text =<< description al
|
|
ul_ $ do
|
|
asks hasRSS >>= rssLink
|
|
li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
|
|
div [class_ "articles"] (
|
|
mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
|
|
)
|
|
where
|
|
otherLink =
|
|
toHtml <$> template (if full then "latestLink" else "allLink") []
|
|
rssLink :: Bool -> HtmlGenerator
|
|
rssLink True = do
|
|
(text, title) <- rssLinkTexts al
|
|
li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
|
|
rssLink False = return ()
|
|
|
|
pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
|
|
|
|
mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator
|
|
mDContent raw base markdown@(Markdown {key, Markdown.body}) =
|
|
article_ ! id (toValue key) (do
|
|
header_ . h1_ $ mDLink raw base markdown
|
|
pre_ . toHtml $ unlines body
|
|
)
|
|
|
|
mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator
|
|
mDLink raw base (Markdown {Markdown.path, Markdown.title}) = link $ toHtml title
|
|
where
|
|
link = a_ [href_ . prefix base $ path <.> (if raw then "md" else "html")]
|
|
|
|
prefix :: FilePath -> FilePath -> Text
|
|
prefix base = pack . (base </>)
|
|
|
|
tag :: FilePath -> String -> HtmlGenerator
|
|
tag base name =
|
|
a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name
|
|
|
|
defaultBanner :: FilePath -> HtmlGenerator
|
|
defaultBanner base =
|
|
div ! id "header" $
|
|
a_ [href_ $ pack base] (
|
|
h1_ . toHtml =<< asks name
|
|
)
|
|
|
|
faviconLink :: FilePath -> URL -> HtmlGenerator
|
|
faviconLink base url = link_ [
|
|
rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
|
|
]
|
|
|
|
optional :: (a -> HtmlGenerator) -> Maybe a -> HtmlGenerator
|
|
optional = maybe (return mempty)
|
|
|
|
navigationSection ::
|
|
Text -> String -> ((String, a) -> HtmlGenerator) -> Map String a -> HtmlGenerator
|
|
navigationSection sectionId templateKey generator collection
|
|
| null collection = return ()
|
|
| otherwise =
|
|
div ! id sectionId ! class_ "navigator" $ do
|
|
h2 . toHtml =<< template templateKey []
|
|
ul $ (li . generator) <$> Map.toList collection
|
|
|
|
htmlDocument :: PageType a => a -> HtmlGenerator
|
|
htmlDocument someContent =
|
|
let base = pathToRoot someContent in
|
|
docTypeHtml (do
|
|
H.head (do
|
|
meta ! charset "utf-8"
|
|
H.title . text =<< asks name
|
|
script ! src (prefix base "js/remarkable.min.js") mempty
|
|
script ! src (prefix base "js/hablo.js") mempty
|
|
optional (faviconLink base) =<< (asks $skin.$favicon)
|
|
optional (Card.make someContent) =<< (asks $urls.$cards)
|
|
optional preEscapedText =<< (asks $skin.$Blog.head)
|
|
)
|
|
H.body (do
|
|
maybe (defaultBanner base) preEscapedText =<< (asks $skin.$banner)
|
|
asks tags >>= navigationSection "tags" "tagsList"
|
|
(\(key, _) -> tag base key)
|
|
asks pages >>= navigationSection "pages" "pagesList"
|
|
(\(_, page) -> mDLink False base $ getMarkdown page)
|
|
div ! id "contents" $ content someContent
|
|
)
|
|
)
|