diff --git a/hablo.cabal b/hablo.cabal index d2dadba..ba55f46 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -56,7 +56,8 @@ library , containers >= 0.5.11 && < 0.7 , directory >= 1.3.1 && < 1.4 , filepath >= 1.4.2 && < 1.5 - , lucid >= 2.8.0 && < 2.10 + , blaze-html + , blaze-markup , mtl >= 2.2.2 && < 2.3 , optparse-applicative >= 0.14.0 && < 0.17 , parsec >= 3.1.13 && < 3.2 diff --git a/src/DOM.hs b/src/DOM.hs index 686f8d9..b3bd062 100644 --- a/src/DOM.hs +++ b/src/DOM.hs @@ -18,22 +18,28 @@ 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 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 (head, lookup) +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 = HtmlT (ReaderT Blog IO) +type HtmlGenerator = ReaderT Blog IO Html class HasCard a => PageType a where - content :: a -> HtmlGenerator () + content :: a -> HtmlGenerator pathToRoot :: a -> FilePath instance PageType Article where @@ -47,17 +53,17 @@ instance PageType Page where instance PageType ArticlesList where content al@(ArticlesList {full}) = do preview <- Article.preview <$> (asks $skin.$previewLinesCount) - h2_ . toHtml =<< description al + h2_ . text =<< description al ul_ $ do asks hasRSS >>= rssLink li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink - div_ [class_ "articles"] ( + 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 :: Bool -> HtmlGenerator rssLink True = do (text, title) <- rssLinkTexts al li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text @@ -65,70 +71,68 @@ instance PageType ArticlesList where pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection -mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator () -mDContent raw base markdown@(Markdown {key, body}) = - article_ [id_ $ pack key] (do +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, title}) = link $ toHtml title +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 :: FilePath -> String -> HtmlGenerator tag base name = a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name -defaultBanner :: FilePath -> HtmlGenerator () +defaultBanner :: FilePath -> HtmlGenerator defaultBanner base = - div_ [id_ "header"] ( - a_ [href_ $ pack base] ( - h1_ . toHtml =<< asks name - ) - ) + div ! id "header" $ + a_ [href_ $ pack base] ( + h1_ . toHtml =<< asks name + ) -faviconLink :: FilePath -> URL -> HtmlGenerator () +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 ()) +optional :: (a -> HtmlGenerator) -> Maybe a -> HtmlGenerator +optional = maybe (return mempty) navigationSection :: - Text -> String -> ((String, a) -> HtmlGenerator ()) -> Map String a -> HtmlGenerator () + 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 - ) + div ! id sectionId ! class_ "navigator" $ do + h2 . toHtml =<< template templateKey [] + ul $ (li . generator) <$> Map.toList collection -htmlDocument :: PageType a => a -> HtmlGenerator () +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 + 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 toHtmlRaw =<< (asks $skin.$head) + optional preEscapedText =<< (asks $skin.$Blog.head) ) - body_ (do - maybe (defaultBanner base) toHtmlRaw =<< (asks $skin.$banner) + 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 + div ! id "contents" $ content someContent ) ) diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index fa0739d..36a8028 100644 --- a/src/DOM/Card.hs +++ b/src/DOM/Card.hs @@ -17,14 +17,16 @@ import Control.Applicative ((<|>)) import Control.Monad.Reader (asks) import qualified Data.Map as Map (lookup) import Data.Text (Text, pack) -import Lucid (HtmlT, content_, meta_) -import Lucid.Base (makeAttribute) +--import Lucid (HtmlT, content_, meta_) +--import Lucid.Base (makeAttribute) import Markdown (MarkdownContent(..), metadata) import Network.URL (URL) import qualified Markdown (Markdown(..)) import Page (Page(..)) import Pretty ((.$)) import System.FilePath.Posix ((), (<.>)) +import Text.Blaze.Html5 ((!), AttributeValue, Html, ToValue(..), meta, customAttribute) +import Text.Blaze.Html5.Attributes as A (content) class HasCard a where cardType :: Renderer m => a -> m Text @@ -33,14 +35,13 @@ class HasCard a where title :: Renderer m => a -> m String urlPath :: Renderer m => a -> m String -og :: Applicative m => Text -> Text -> HtmlT m () -og attribute value = - meta_ [ - makeAttribute "property" $ "og:" <> attribute - , content_ value - ] +og :: Applicative m => AttributeValue -> Text -> m Html +og attribute t = + pure $ meta + ! (customAttribute "property" $ "og:" <> attribute) + ! content (toValue t) -make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> HtmlT m () +make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> m Html make element siteURL = do og "url" . (pathOn siteURL) =<< urlPath element og "type" =<< cardType element @@ -49,7 +50,7 @@ make element siteURL = do maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage)) og "site_name" =<< (asks $name.$pack) where - maybeImage = maybe (return ()) (og "image" . defaultOn siteURL) + maybeImage = maybe (return mempty) (og "image" . defaultOn siteURL) mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL) mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown diff --git a/src/RSS.hs b/src/RSS.hs index 0f5b5fa..6207646 100644 --- a/src/RSS.hs +++ b/src/RSS.hs @@ -19,13 +19,14 @@ import Data.Map ((!)) import qualified Data.Text.Lazy.IO as TextIO (writeFile) import Data.Time (defaultTimeLocale, formatTime, rfc822DateFormat) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT) +--import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT) import Lucid.Base (makeAttribute) import Markdown (Markdown(..)) import Pretty ((.$)) import System.FilePath.Posix ((), (<.>)) +import Text.Blaze.Html (Html) -prolog :: Monad m => HtmlT m () +prolog :: Monad m => m Html prolog = toHtmlRaw ("" :: String) version_ :: Text -> Attribute @@ -58,7 +59,7 @@ item_ = term "item" pubDate_ :: Term arg result => arg -> result pubDate_ = term "pubDate" -articleItem :: Monad m => AbsoluteURL -> Article -> HtmlT m () +articleItem :: Monad m => AbsoluteURL -> Article -> m Html articleItem siteURL (Article (Markdown {path, metadata, title})) = item_ $ do title_ $ toHtml title @@ -69,7 +70,7 @@ articleItem siteURL (Article (Markdown {path, metadata, title})) = formatTime defaultTimeLocale rfc822DateFormat . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int) -feed :: Renderer m => AbsoluteURL -> ArticlesList -> HtmlT m () +feed :: Renderer m => AbsoluteURL -> ArticlesList -> m Html feed siteURL al@(ArticlesList {collection}) = do prolog rss_ [version, content, atom] $ do