From 2373c925e18963c6f2698ba4c45d74196f3aaaf3 Mon Sep 17 00:00:00 2001 From: Vincent Ambo Date: Fri, 28 Jun 2019 22:55:13 +0100 Subject: refactor: Move tazblog into monorepo structure It's happening! --- services/tazblog/src/Blog.hs | 234 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 234 insertions(+) create mode 100644 services/tazblog/src/Blog.hs (limited to 'services/tazblog/src/Blog.hs') diff --git a/services/tazblog/src/Blog.hs b/services/tazblog/src/Blog.hs new file mode 100644 index 000000000000..f35e3d90801f --- /dev/null +++ b/services/tazblog/src/Blog.hs @@ -0,0 +1,234 @@ +module Blog where + +import BlogDB +import Data.Maybe (fromJust) +import Data.Text (Text, append, empty, pack) +import Data.Text.Lazy (fromStrict) +import Data.Time +import Locales +import Text.Blaze.Html (preEscapedToHtml) +import Text.Hamlet +import Text.Markdown + +import qualified Data.Text as T + +replace :: Eq a => a -> a -> [a] -> [a] +replace x y = map (\z -> if z == x then y else z) + +show' :: Show a => a -> Text +show' = pack . show + +-- |After this time all entries are Markdown +markdownCutoff :: UTCTime +markdownCutoff = fromJust $ parseTimeM False defaultTimeLocale "%s" "1367149834" + +-- blog HTML +blogTemplate :: BlogLang -> Text -> Html -> Html +blogTemplate lang t_append body = [shamlet| +$doctype 5 + + + + + + + #{blogTitle lang t_append} + <body> + <header> + <h1> + <a href="/" .unstyled-link>#{blogTitle lang empty} + <hr> + ^{body} + ^{showFooter} +|] + where + rssUrl = T.concat ["/", show' lang, "/rss.xml"] + +showFooter :: Html +showFooter = [shamlet| +<footer> + <p .footer>Served without any dynamic languages. + <p .footer> + <a href=#{repoURL} .uncoloured-link>Version #{version} + | + <a href=#{twitter} .uncoloured-link>Twitter + | + <a href=#{mailTo} .uncoloured-link>Mail + <p .lod> + ಠ_ಠ +|] + +isEntryMarkdown :: Entry -> Bool +isEntryMarkdown e = edate e > markdownCutoff + +renderEntryMarkdown :: Text -> Html +renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict + +renderEntries :: Bool -> [Entry] -> Maybe Html -> Html +renderEntries showAll entries pageLinks = [shamlet| +$forall entry <- toDisplay + <article> + <h2 .inline> + <a href=#{linkElems entry} .unstyled-link> + #{title entry} + <aside .date> + #{pack $ formatTime defaultTimeLocale "%Y-%m-%d" $ edate entry} + $if (isEntryMarkdown entry) + ^{renderEntryMarkdown $ btext entry} + $else + ^{preEscapedToHtml $ btext entry} + $if ((/=) (mtext entry) empty) + <p> + <a .uncoloured-link href=#{linkElems entry}> + #{readMore $ lang entry} + <hr> +$maybe links <- pageLinks + ^{links} +|] + where + toDisplay = if showAll then entries else (take 6 entries) + linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId] + +showLinks :: Maybe Int -> BlogLang -> Html +showLinks (Just i) lang = [shamlet| + $if ((>) i 1) + <div .navigation> + <a href=#{nLink $ succ i} .uncoloured-link>#{backText lang} + | + <a href=#{nLink $ pred i} .uncoloured-link>#{nextText lang} + $elseif ((<=) i 1) + ^{showLinks Nothing lang} +|] + where + nLink page = T.concat ["/", show' lang, "/?page=", show' page] +showLinks Nothing lang = [shamlet| +<div .navigation> + <a href=#{nLink} .uncoloured-link>#{backText lang} +|] + where + nLink = T.concat ["/", show' lang, "/?page=2"] + +renderEntry :: Entry -> Html +renderEntry e@Entry{..} = [shamlet| +<article> + <h2 .inline> + #{title} + <aside .date> + #{pack $ formatTime defaultTimeLocale "%Y-%m-%d" edate} + $if (isEntryMarkdown e) + ^{renderEntryMarkdown btext} + <p>^{renderEntryMarkdown $ mtext} + $else + ^{preEscapedToHtml $ btext} + <p>^{preEscapedToHtml $ mtext} +<hr> +|] + +{- Administration pages -} + +adminTemplate :: Text -> Html -> Html +adminTemplate title body = [shamlet| +$doctype 5 +<head> + <link rel="stylesheet" type="text/css" href="/static/admin.css" media="all"> + <meta http-equiv="content-type" content="text/html;charset=UTF-8"> + <title>#{append "TazBlog Admin: " title} +<body> + ^{body} +|] + +adminLogin :: Html +adminLogin = adminTemplate "Login" $ [shamlet| +<div class="loginBox"> + <div class="loginBoxTop">TazBlog Admin: Login + <div class="loginBoxMiddle"> + <form action="/admin" method="POST"> + <p>Account ID + <p><input type="text" style="font-size:2;" name="account" value="tazjin" readonly="1"> + <p>Passwort + <p><input type="password" style="font-size:2;" name="password"> + <p><input alt="Anmelden" type="image" src="/static/signin.gif"> +|] + +adminIndex :: Text -> Html +adminIndex sUser = adminTemplate "Index" $ [shamlet| +<div style="float:center;"> + <form action="/admin/entry" method="POST"> + <table> + <tr> + <thead><td>Title: + <td><input type="text" name="title"> + <tr> + <thead><td>Language: + <td><select name="lang"> + <option value="en">English + <option value="de">Deutsch + <tr> + <thead><td>Text: + <td> + <textarea name="btext" cols="100" rows="15"> + <tr> + <thead> + <td style="vertical-align:top;">Read more: + <td> + <textarea name="mtext" cols="100" rows="15"> + <input type="hidden" name="author" value=#{sUser}> + <input style="margin-left:20px;" type="submit" value="Submit"> + ^{adminFooter} +|] + +adminFooter :: Html +adminFooter = [shamlet| +<a href="/">Front page +\ -- # + <a href="/admin">New article +\ -- Entry list: # + <a href="/admin/entrylist/en">EN +\ & # +<a href="/admin/entrylist/de">DE +|] + +adminEntryList :: [Entry] -> Html +adminEntryList entries = adminTemplate "EntryList" $ [shamlet| +<div style="float: center;"> + <table> + $forall entry <- entries + <tr> + <td><a href=#{append "/admin/entry/" (show' $ entryId entry)}>#{title entry} + <td>#{formatPostDate $ edate entry} +|] + where + formatPostDate = formatTime defaultTimeLocale "[On %D at %H:%M]" + +editPage :: Entry -> Html +editPage (Entry{..}) = adminTemplate "Index" $ [shamlet| +<div style="float:center;"> + <form action=#{append "/admin/entry/" (show' entryId)} method="POST"> + <table> + <tr> + <td>Title: + <td> + <input type="text" name="title" value=#{title}> + <tr> + <td style="vertical-align:top;">Text: + <td> + <textarea name="btext" cols="100" rows="15">#{btext} + <tr> + <td style="vertical-align:top;">Read more: + <td> + <textarea name="mtext" cols="100" rows="15">#{mtext} + <input type="submit" style="margin-left:20px;" value="Submit"> + <p>^{adminFooter} +|] + +showError :: BlogError -> BlogLang -> Html +showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ [shamlet| +<p>:( +<p>#{notFoundText l} +<hr> +|] +showError UnknownError l = blogTemplate l "" $ [shamlet| +<p>:( +<p>#{unknownErrorText l} +<hr> +|] -- cgit 1.4.1