* added Markdown support

This commit is contained in:
"Vincent Ambo ext:(%22) 2013-04-28 14:26:45 +02:00
parent 0f98c3f489
commit 8f1b6b5c4e
2 changed files with 31 additions and 7 deletions

View file

@ -36,4 +36,5 @@ Executable tazblog
rss, rss,
recaptcha, recaptcha,
hamlet, hamlet,
shakespeare-css shakespeare-css,
markdown

View file

@ -5,14 +5,17 @@ module Blog where
import Control.Monad (when, unless) import Control.Monad (when, unless)
import Data.Data (Data, Typeable) import Data.Data (Data, Typeable)
import Data.List (intersperse) import Data.List (intersperse)
import Data.Maybe (fromJust)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Text (Text, append, pack, empty) import Data.Text (Text, append, pack, empty)
import Data.Text.Lazy (fromStrict)
import Data.Time import Data.Time
import Network.Captcha.ReCaptcha import Network.Captcha.ReCaptcha
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html (preEscapedToHtml)
import Text.Hamlet import Text.Hamlet
import Text.Lucius import Text.Lucius
import Text.Markdown
import Locales import Locales
import BlogDB import BlogDB
@ -28,11 +31,16 @@ replace x y = map (\z -> if z == x then y else z)
show' :: Show a => a -> Text show' :: Show a => a -> Text
show' = pack . show show' = pack . show
-- |After this time all entries are Markdown
markdownCutoff :: UTCTime
markdownCutoff = fromJust $ parseTime defaultTimeLocale "%s" "1367149834"
data BlogURL = BlogURL data BlogURL = BlogURL
-- blog CSS (admin is still static) -- blog CSS (admin is still static)
stylesheetSource = $(luciusFile "res/blogstyle.lucius") stylesheetSource = $(luciusFile "res/blogstyle.lucius")
blogStyle = renderCssUrl undefined stylesheetSource blogStyle = renderCssUrl undefined stylesheetSource
-- blog HTML -- blog HTML
blogTemplate :: BlogLang -> Text -> Html -> Html blogTemplate :: BlogLang -> Text -> Html -> Html
blogTemplate lang t_append body = [shamlet| blogTemplate lang t_append body = [shamlet|
@ -78,6 +86,12 @@ showFooter l v = [shamlet|
<a class="link" href="/notice">#{noticeText l} <a class="link" href="/notice">#{noticeText l}
|] |]
isEntryMarkdown :: Entry -> Bool
isEntryMarkdown e = edate e > markdownCutoff
renderEntryMarkdown :: Text -> Html
renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
renderEntries :: Bool -> [Entry] -> Text -> Maybe Html -> Html renderEntries :: Bool -> [Entry] -> Text -> Maybe Html -> Html
renderEntries showAll entries topText footerLinks = [shamlet| renderEntries showAll entries topText footerLinks = [shamlet|
<span class="innerTitle">#{topText} <span class="innerTitle">#{topText}
@ -85,6 +99,11 @@ renderEntries showAll entries topText footerLinks = [shamlet|
<ul style="max-width:57em;"> <ul style="max-width:57em;">
$forall entry <- elist $forall entry <- elist
<li> <li>
$if (isEntryMarkdown entry)
<a href=#{linkElems entry}>#{linkText $ length $ comments entry}
<b>#{title entry}
^{renderEntryMarkdown $ append " " $ btext entry}
$else
<a href=#{linkElems entry}>#{linkText $ length $ comments entry} <a href=#{linkElems entry}>#{linkText $ length $ comments entry}
^{preEscapedToHtml $ append " " $ btext entry} ^{preEscapedToHtml $ append " " $ btext entry}
$if ((/=) (mtext entry) empty) $if ((/=) (mtext entry) empty)
@ -119,7 +138,7 @@ showLinks Nothing lang = [shamlet|
nLink = T.concat ["/", show' lang, "/?page=2"] nLink = T.concat ["/", show' lang, "/?page=2"]
renderEntry :: Entry -> Html renderEntry :: Entry -> Html
renderEntry Entry{..} = [shamlet| renderEntry e@Entry{..} = [shamlet|
<span class="innerTitle">#{title} <span class="innerTitle">#{title}
<span class="righttext"> <span class="righttext">
<i>#{woText} <i>#{woText}
@ -127,6 +146,10 @@ renderEntry Entry{..} = [shamlet|
<article> <article>
<ul style="max-width:57em;"> <ul style="max-width:57em;">
<li> <li>
$if (isEntryMarkdown e)
^{renderEntryMarkdown btext}
<p>^{renderEntryMarkdown $ mtext}
$else
^{preEscapedToHtml $ btext} ^{preEscapedToHtml $ btext}
<p>^{preEscapedToHtml $ mtext} <p>^{preEscapedToHtml $ mtext}
<div class="innerBoxComments"> <div class="innerBoxComments">