135 lines
4.5 KiB
Haskell
135 lines
4.5 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 (
|
|
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 (head, lookup)
|
|
import Pretty ((.$))
|
|
import System.FilePath.Posix ((</>), (<.>))
|
|
|
|
type HtmlGenerator = HtmlT (ReaderT Blog IO)
|
|
|
|
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_ . toHtml =<< 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, body}) =
|
|
article_ [id_ $ pack key] (do
|
|
header_ . h1_ $ mDLink raw base markdown
|
|
pre_ . toHtml $ unlines body
|
|
)
|
|
|
|
mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
|
|
mDLink raw base (Markdown {Markdown.path, 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 ())
|
|
|
|
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_ . mapM_ (li_ . generator) $ Map.toList collection
|
|
)
|
|
|
|
htmlDocument :: PageType a => a -> HtmlGenerator ()
|
|
htmlDocument someContent =
|
|
let base = pathToRoot someContent in
|
|
doctypehtml_ (do
|
|
head_ (do
|
|
meta_ [charset_ "utf-8"]
|
|
title_ . toHtml =<< asks name
|
|
script_ [src_ $ prefix base "js/remarkable.min.js"] empty
|
|
script_ [src_ $ prefix base "js/hablo.js"] empty
|
|
optional (faviconLink base) =<< (asks $skin.$favicon)
|
|
optional (Card.make someContent) =<< (asks $urls.$cards)
|
|
optional toHtmlRaw =<< (asks $skin.$head)
|
|
)
|
|
body_ (do
|
|
maybe (defaultBanner base) toHtmlRaw =<< (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
|
|
)
|
|
)
|