* almost done moving to Hamlet from Blaze
This commit is contained in:
Vincent Ambo
parent
e28c43f018
commit
8a750bd133
1 changed files with 269 additions and 244 deletions
513
src/Blog.hs
513
src/Blog.hs
|
|
@ -1,25 +1,20 @@
|
||||||
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards #-}
|
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable, QuasiQuotes, RecordWildCards #-}
|
||||||
|
|
||||||
module Blog where
|
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.Monoid (mempty)
|
import Data.Monoid (mempty)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text, append, pack, empty)
|
||||||
import qualified Data.Text as T
|
import Data.Time
|
||||||
import Data.Time
|
import Network.Captcha.ReCaptcha
|
||||||
import Network.Captcha.ReCaptcha
|
import System.Locale (defaultTimeLocale)
|
||||||
import System.Locale (defaultTimeLocale)
|
import Text.Hamlet
|
||||||
import Text.Blaze (toValue, preEscapedText, preEscapedString)
|
import Locales
|
||||||
import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)
|
import BlogDB
|
||||||
import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value)
|
|
||||||
import qualified Text.Blaze.Html5 as H
|
|
||||||
import qualified Text.Blaze.Html5.Attributes as A
|
|
||||||
import Text.XHtml.Strict (showHtmlFragment)
|
|
||||||
|
|
||||||
import Locales
|
import qualified Data.Text as T
|
||||||
import BlogDB
|
|
||||||
|
|
||||||
-- custom list functions
|
-- custom list functions
|
||||||
intersperse' :: a -> [a] -> [a]
|
intersperse' :: a -> [a] -> [a]
|
||||||
|
|
@ -28,21 +23,12 @@ intersperse' sep l = sep : intersperse sep l
|
||||||
replace :: Eq a => a -> a -> [a] -> [a]
|
replace :: Eq a => a -> a -> [a] -> [a]
|
||||||
replace x y = map (\z -> if z == x then y else z)
|
replace x y = map (\z -> if z == x then y else z)
|
||||||
|
|
||||||
|
show' :: Show a => a -> Text
|
||||||
|
show' = pack . show
|
||||||
|
|
||||||
|
data BlogURL = BlogURL
|
||||||
|
|
||||||
-- javascript and others
|
-- javascript and others
|
||||||
|
|
||||||
captcha :: Html
|
|
||||||
captcha = H.div ! A.class_ "cCaptcha" $
|
|
||||||
do H.script ! A.src "http://api.recaptcha.net/challenge?k=6LfQXccSAAAAAIjKm26XlFnBMAgvaKlOAjVWEEnM" ! A.type_ "text/javascript" $ ""
|
|
||||||
H.noscript $ H.iframe ! A.src "http://api.recaptcha.net/noscript?k=6LfQXccSAAAAAIjKm26XlFnBMAgvaKlOAjVWEEnM" ! A.height "300" !
|
|
||||||
A.width "500" ! A.seamless "" $ do
|
|
||||||
H.br
|
|
||||||
H.textarea ! A.name "recaptcha_challenge_field" ! A.rows "3" ! A.cols "40" $ ""
|
|
||||||
H.input ! A.type_ "hidden" ! A.name "recaptcha_response_field" ! A.value "manual_challenge"
|
|
||||||
|
|
||||||
captchaOptions :: BlogLang -> Html
|
|
||||||
captchaOptions lang = H.script ! A.type_ "text/javascript" $ toHtml $
|
|
||||||
T.concat ["var RecaptchaOptions = { theme: 'clean', lang: '", showLangText lang, "'};"]
|
|
||||||
|
|
||||||
analytics :: Text
|
analytics :: Text
|
||||||
analytics = T.pack $ unlines ["<script type=\"text/javascript\">"
|
analytics = T.pack $ unlines ["<script type=\"text/javascript\">"
|
||||||
," var _gaq = _gaq || [];"
|
," var _gaq = _gaq || [];"
|
||||||
|
|
@ -56,240 +42,279 @@ analytics = T.pack $ unlines ["<script type=\"text/javascript\">"
|
||||||
,"</script>"]
|
,"</script>"]
|
||||||
|
|
||||||
-- blog HTML
|
-- blog HTML
|
||||||
|
|
||||||
blogTemplate :: BlogLang -> Text -> Html -> Html
|
blogTemplate :: BlogLang -> Text -> Html -> Html
|
||||||
blogTemplate lang t_append body = H.docTypeHtml $ do --add body
|
blogTemplate lang t_append body = [shamlet|
|
||||||
H.head $ do
|
$doctype 5
|
||||||
H.title $ (toHtml $ blogTitle lang t_append)
|
<head>
|
||||||
H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href (toValue feedURL)
|
<title>#{blogTitle lang t_append}
|
||||||
H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/static/blogv33.css" ! A.media "all"
|
<link rel="stylesheet" type="text/css" href="/static/blogv33.css" media="all">
|
||||||
--H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/blogstyle.css" ! A.media "all"
|
<link rel="alternate" type="application/rss+xml" title="RSS-Feed" href=#{rssUrl}>
|
||||||
H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
|
<meta http-equiv="content-type" content="text/html;charset=UTF-8">
|
||||||
--H.style ! A.type_ "text/css" ! A.title "iOS iMessage" ! A.media "screen and (max-device-width: 1024px)" $ "#cosx{display:none;}"
|
#{analytics}
|
||||||
preEscapedText analytics
|
<body>
|
||||||
H.body $ do
|
<div class="header">
|
||||||
H.div ! A.class_ "header" $ do
|
<a class="btitle" href=#{append "/" (show' lang)}>#{blogTitle lang empty}
|
||||||
H.a ! A.class_ "btitle" ! A.href (toValue $ "/" ++ show lang) $
|
<p style="clear: both;">
|
||||||
toHtml $ blogTitle lang ""
|
<span class="contacts" id="cosx">#{contactInfo iMessage}
|
||||||
H.p ! A.style "clear: both;" $ do
|
<span class="righttext">#{rightText lang}
|
||||||
H.span ! A.class_ "contacts" ! A.id "cosx" $ contactInfo iMessage
|
<div class="middle">
|
||||||
-- H.span ! A.id "cios" ! A.style "display:none;" $ H.b $ contactInfo "sms:tazjin@me.com"
|
#{body}
|
||||||
H.span ! A.class_ "righttext" $ preEscapedText $ rightText lang
|
<div class="footer">
|
||||||
H.div ! A.class_ "middle" $ do
|
#{showFooter lang $ pack version}
|
||||||
body
|
<div class="centerbox">
|
||||||
H.div ! A.class_ "footer" $ do
|
<span style="font-size:17px;font-family:Helvetica;">ಠ_ಠ
|
||||||
showFooter lang $ T.pack version
|
|]
|
||||||
H.div ! A.class_ "centerbox" $
|
where
|
||||||
H.span ! A.style "font-size: 17px; font-family: Helvetica;" $ "ಠ_ಠ"
|
rssUrl = T.concat ["/", show' lang, "/rss.xml"]
|
||||||
--H.img ! A.src "http://cl.ly/F9m4/idiots.png" ! A.alt ""
|
contactInfo imu = [shamlet|
|
||||||
where
|
#{contactText lang}
|
||||||
contactInfo (imu :: Text) = do
|
<a class="link" href=#{mailTo}>Mail
|
||||||
toHtml $ contactText lang
|
, #
|
||||||
H.a ! A.class_ "link" ! A.href (toValue mailTo) $ "Mail"
|
<a class="link" href=#{twitter} target="_blank">Twitter
|
||||||
", "
|
#{orText lang}
|
||||||
H.a ! A.class_ "link" ! A.href (toValue twitter) ! A.target "_blank" $ "Twitter"
|
<a class="link" href=#{imu} target="_blank">iMessage
|
||||||
toHtml $ orText lang
|
.
|
||||||
H.a ! A.class_ "link" ! A.href (toValue imu) ! A.target "_blank" $ "iMessage"
|
|]
|
||||||
"."
|
|
||||||
feedURL = "/" ++ show lang ++ "/rss.xml"
|
|
||||||
|
|
||||||
renderEntries :: Bool -> [Entry] -> Text -> Maybe Html -> Html
|
|
||||||
renderEntries showAll entries topText footerLinks = do
|
|
||||||
H.span ! A.class_ "innerTitle" $ toHtml topText
|
|
||||||
H.div ! A.class_ "innerContainer" $ do
|
|
||||||
H.ul ! A.style "max-width: 57em;" $ if' showAll
|
|
||||||
(mapM_ showEntry entries)
|
|
||||||
(mapM_ showEntry $ take 6 entries)
|
|
||||||
getFooterLinks footerLinks
|
|
||||||
where
|
|
||||||
showEntry :: Entry -> Html
|
|
||||||
showEntry e = H.li $ do
|
|
||||||
entryLink e $ T.pack $ show(length $ comments e)
|
|
||||||
preEscapedText $ T.append " " $ btext e
|
|
||||||
when ( mtext e /= T.empty ) $
|
|
||||||
H.p $ entryLink e $ readMore $ lang e
|
|
||||||
unless ( mtext e /= T.empty ) $
|
|
||||||
preEscapedText "<br> "
|
|
||||||
entryLink :: Entry -> Text -> Html
|
|
||||||
entryLink e s = H.a ! A.href (toValue $ concat $ intersperse' "/" $ linkElems e) $
|
|
||||||
toHtml (T.concat ["[", s, "]"])
|
|
||||||
linkElems e = [show(lang e), show $ entryId e]
|
|
||||||
getFooterLinks (Just h) = h
|
|
||||||
getFooterLinks Nothing = mempty
|
|
||||||
|
|
||||||
renderEntry :: Entry -> Html
|
|
||||||
renderEntry (Entry{..}) = do
|
|
||||||
H.span ! A.class_ "innerTitle" $ toHtml $ title
|
|
||||||
H.span ! A.class_ "righttext" $ H.i $ toHtml $ woText
|
|
||||||
H.div ! A.class_ "innerContainer" $ do
|
|
||||||
H.article $ H.ul ! A.style "max-width: 57em;" $ H.li $ do
|
|
||||||
preEscapedText $ btext
|
|
||||||
H.p $ preEscapedText $ mtext
|
|
||||||
H.div ! A.class_ "innerBoxComments" $ do
|
|
||||||
H.div ! A.class_ "cHead" $ toHtml $ cHead lang -- ! A.style "font-size:large;font-weight:bold;"
|
|
||||||
H.ul ! A.style "max-width: 57em;" $ renderComments comments lang
|
|
||||||
renderCommentBox lang entryId
|
|
||||||
where
|
|
||||||
woText = flip T.append author $ T.pack $ (formatTime defaultTimeLocale (eTimeFormat lang) edate)
|
|
||||||
|
|
||||||
renderCommentBox :: BlogLang -> EntryId -> Html
|
|
||||||
renderCommentBox cLang cId = do
|
|
||||||
H.div ! A.class_ "cHead" $ toHtml $ cwHead cLang
|
|
||||||
captchaOptions cLang
|
|
||||||
H.form ! A.method "POST" ! A.action (toValue $ "/" ++ (show cLang) ++ "/postcomment/" ++ show cId) $ do
|
|
||||||
H.p $ H.input ! A.name "cname" ! A.placeholder "Name" ! A.class_ "cInput"
|
|
||||||
H.p $ H.label $ H.textarea ! A.name "ctext" ! A.cols "50" ! A.rows "13" ! A.class_ "cInput" !
|
|
||||||
A.placeholder (toValue $ cTextPlaceholder cLang) $ mempty
|
|
||||||
-- H.p $ H.label $ captcha
|
|
||||||
H.p $ H.input ! A.class_ "cInput" ! A.style "width: 120px;" ! A.type_ "submit" ! A.value (toValue $ cSend cLang)
|
|
||||||
|
|
||||||
renderComments :: [Comment] -> BlogLang -> Html
|
|
||||||
renderComments [] lang = H.li $ toHtml $ noComments lang
|
|
||||||
renderComments comments lang = mapM_ showComment comments
|
|
||||||
where
|
|
||||||
showComment :: Comment -> Html
|
|
||||||
showComment (Comment{..}) = H.li $ do
|
|
||||||
H.i $ toHtml $ T.append cauthor ": "
|
|
||||||
preEscapedText ctext
|
|
||||||
H.p ! A.class_ "tt" $ toHtml $ timeString cdate
|
|
||||||
timeString t = formatTime defaultTimeLocale (cTimeFormat lang) t
|
|
||||||
|
|
||||||
showLinks :: Maybe Int -> BlogLang -> Html
|
|
||||||
showLinks (Just i) lang
|
|
||||||
| ( i > 1) = H.div ! A.class_ "centerbox" $ do
|
|
||||||
H.a ! A.href (toValue $ "/" ++ show lang ++ "/?page=" ++ show (i+1)) $
|
|
||||||
toHtml $ backText lang
|
|
||||||
toHtml (" -- " :: Text)
|
|
||||||
H.a ! A.href (toValue $ "/" ++ show lang ++ "/?page=" ++ show (i-1)) $
|
|
||||||
toHtml $ nextText lang
|
|
||||||
| ( i <= 1 ) = showLinks Nothing lang
|
|
||||||
showLinks Nothing lang = H.div ! A.class_ "centerbox" $
|
|
||||||
H.a ! A.href (toValue $ "/" ++ show lang ++ "/?page=2") $
|
|
||||||
toHtml $ backText lang
|
|
||||||
|
|
||||||
showFooter :: BlogLang -> Text -> Html
|
showFooter :: BlogLang -> Text -> Html
|
||||||
showFooter l v = H.div ! A.class_ "rightbox" ! A.style "text-align:right;" $ do
|
showFooter l v = [shamlet|
|
||||||
toHtml ("Proudly made with " :: Text)
|
<div class="rightbox" style="text-align:right;">
|
||||||
H.a ! A.class_ "link" ! A.href "http://haskell.org" $ "Haskell"
|
Proudly made with #
|
||||||
toHtml (", " :: Text)
|
<a class="link" href="http://haskell.org">Haskell
|
||||||
H.a ! A.class_ "link" ! A.href "http://hackage.haskell.org/package/acid-state-0.6.3" $ "Acid-State"
|
, #
|
||||||
toHtml (" and without PHP, Java, Perl, MySQL and Python." :: Text)
|
<a class="link" href="http://hackage.haskell.org/package/acid-state-0.6.3">Acid-State
|
||||||
H.br
|
/ and without PHP, Java, Perl, MySQL and Python.
|
||||||
H.a ! A.class_ "link" ! A.href (toValue repoURL) $ toHtml $ T.append "Version " v
|
<p>
|
||||||
preEscapedText " "
|
<a class="link" href=#{repoURL}>#{append "Version " v}
|
||||||
H.a ! A.class_ "link" ! A.href "/notice" $ toHtml $ noticeText l
|
|
||||||
|
<a class="link" href="/notice">#{noticeText l}
|
||||||
|
|]
|
||||||
|
|
||||||
|
renderEntries :: Bool -> [Entry] -> Text -> Maybe Html -> Html
|
||||||
|
renderEntries showAll entries topText footerLinks = [shamlet|
|
||||||
|
<span class="innerTitle">#{topText}
|
||||||
|
<div class="innerContainer">
|
||||||
|
<ul style="max-width:57em;">
|
||||||
|
$forall entry <- elist
|
||||||
|
<li>
|
||||||
|
<a href=#{linkElems entry}>#{linkText $ length $ comments entry}
|
||||||
|
#{append " " $ btext entry}
|
||||||
|
$if ((/=) (mtext entry) empty)
|
||||||
|
<p><a href=#{linkElems entry}>#{readMore $ lang entry}
|
||||||
|
$else
|
||||||
|
<br>
|
||||||
|
$maybe links <- footerLinks
|
||||||
|
#{links}
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
elist = if' showAll entries (take 6 entries)
|
||||||
|
linkElems Entry{..} = concat $ intersperse' "/" [show lang, show entryId]
|
||||||
|
linkText n = T.concat ["[", show' n, "]"]
|
||||||
|
|
||||||
|
showLinks :: Maybe Int -> BlogLang -> Html
|
||||||
|
showLinks (Just i) lang = [shamlet|
|
||||||
|
$if ((>) i 1)
|
||||||
|
<div class="centerbox">
|
||||||
|
<a href=#{nLink $ succ i}>#{backText lang}
|
||||||
|
/ -- #
|
||||||
|
<a href=#{nLink $ pred i}>#{nextText lang}
|
||||||
|
$elseif ((<=) i 1)
|
||||||
|
#{showLinks Nothing lang}
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
nLink page = T.concat ["/", show' lang, "/?page=", show' page]
|
||||||
|
showLinks Nothing lang = [shamlet|
|
||||||
|
<div class="centerbox">
|
||||||
|
<a href=#{nLink}>#{backText lang}
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
nLink = T.concat ["/", show' lang, "/?page=2"]
|
||||||
|
|
||||||
|
renderEntry :: Entry -> Html
|
||||||
|
renderEntry Entry{..} = [shamlet|
|
||||||
|
<span class="innerTitle">#{title}
|
||||||
|
<span class="righttext"><i>#{woText}
|
||||||
|
<div class="innerContainer">
|
||||||
|
<article>
|
||||||
|
<ul style="max-width:57em;">
|
||||||
|
<li>
|
||||||
|
#{btext}
|
||||||
|
<p>#{mtext}
|
||||||
|
<div class="innerBoxComments">
|
||||||
|
<div class="cHead">#{cHead lang}
|
||||||
|
<ul style="max-width:57em;">#{renderComments comments lang}
|
||||||
|
#{renderCommentBox lang entryId}
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
woText = flip T.append author $ T.pack $ (formatTime defaultTimeLocale (eTimeFormat lang) edate)
|
||||||
|
|
||||||
|
renderComments :: [Comment] -> BlogLang -> Html
|
||||||
|
renderComments [] lang = [shamlet|<li>#{noComments lang}|]
|
||||||
|
renderComments comments lang = [shamlet|
|
||||||
|
$forall comment <- comments
|
||||||
|
<li>
|
||||||
|
<i>#{append (cauthor comment) ": "}
|
||||||
|
#{ctext comment}
|
||||||
|
<p class="tt">#{timeString $ cdate comment}
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
timeString = formatTime defaultTimeLocale (cTimeFormat lang)
|
||||||
|
|
||||||
|
|
||||||
|
renderCommentBox :: BlogLang -> EntryId -> Html
|
||||||
|
renderCommentBox cLang cId = [shamlet|
|
||||||
|
<div class="cHead">#{cwHead cLang}
|
||||||
|
<form method="POST" action=#{aLink}>
|
||||||
|
<p><input name="cname" placeholder="Name" class="cInput">
|
||||||
|
<p>
|
||||||
|
<label>
|
||||||
|
<textarea name="ctext" cols="50" rows="13" class="cInput" placeholder=#{cTextPlaceholder cLang}>
|
||||||
|
<p><input class="cInput" style="width:120px;" type="submit" value=#{cSend cLang}>
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
aLink = T.concat ["/", show' cLang, "/postcomment", show' cId]
|
||||||
|
|
||||||
showSiteNotice :: Html
|
showSiteNotice :: Html
|
||||||
showSiteNotice = H.docTypeHtml $ do
|
showSiteNotice = [shamlet|
|
||||||
H.title $ "Impressum"
|
$doctype 5
|
||||||
H.h2 $ preEscapedText "Impressum und <a alt=\"Verantwortlich im Sinne des Presserechtes\">ViSdP</a>"
|
<head>
|
||||||
H.i $ "[German law demands this]"
|
<title>Impressum
|
||||||
H.br
|
<body>
|
||||||
H.p $ do
|
<h2>
|
||||||
toHtml ("Vincent Ambo" :: Text)
|
Impressum und #
|
||||||
H.br
|
<a alt="Verantwortlich im Sinne des Presserechtes">ViSdP
|
||||||
toHtml ("Benfleetstr. 8" :: Text)
|
<i>[German law demands this]
|
||||||
H.br
|
<br>
|
||||||
toHtml ("50858 Köln" :: Text)
|
<p>
|
||||||
H.p $ H.a ! A.href "/" ! A.style "color:black" $ "Back"
|
Vincent Ambo
|
||||||
|
<br>
|
||||||
|
Benfleetstr. 8
|
||||||
|
<br>
|
||||||
|
50858 Köln
|
||||||
|
<p><a href="/" style="color:black;">Back
|
||||||
|
|]
|
||||||
|
|
||||||
{- Administration pages -}
|
{- Administration pages -}
|
||||||
|
|
||||||
adminTemplate :: Text -> Html -> Html
|
adminTemplate :: Text -> Html -> Html
|
||||||
adminTemplate title body = H.docTypeHtml $ do
|
adminTemplate title body = [shamlet|
|
||||||
H.head $ do
|
$doctype 5
|
||||||
H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/static/admin.css" ! A.media "all"
|
<head>
|
||||||
H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
|
<link rel="stylesheet" type="text/css" href="/static/admin.css" media="all">
|
||||||
H.title $ toHtml $ T.append "TazBlog Admin: " title
|
<meta http-equiv="content-type" content="text/html;charset=UTF-8">
|
||||||
H.body
|
<title>#{append "TazBlog Admin: " title}
|
||||||
body
|
<body>
|
||||||
|
#{body}
|
||||||
|
|]
|
||||||
|
|
||||||
adminLogin :: Html
|
adminLogin :: Html
|
||||||
adminLogin = adminTemplate "Login" $
|
adminLogin = adminTemplate "Login" $ [shamlet|
|
||||||
H.div ! A.class_ "loginBox" $ do
|
<div class="loginBox">
|
||||||
H.div ! A.class_ "loginBoxTop" $ "TazBlog Admin: Login"
|
<div class="loginBoxTop">TazBlog Admin: Login
|
||||||
H.div ! A.class_ "loginBoxMiddle" $ H.form ! A.action "/dologin" ! A.method "post" $ do
|
<div class="loginBoxMiddle">
|
||||||
H.p $ "Account ID"
|
<form action="/dologin" method="POST">
|
||||||
H.p $ H.input ! A.type_ "text" ! A.style "font-size: 2;"
|
<p>Account ID
|
||||||
! A.name "account" -- ! A.value "tazjin" ! A.readonly "1"
|
<p><input type="text" style="font-size:2;" name="account" value="tazjin" readonly="1">
|
||||||
H.p $ "Passwort"
|
<p>Passwort
|
||||||
H.p $ H.input ! A.type_ "password" ! A.style "font-size: 2;" ! A.name "password"
|
<p><input type="password" style="font-size:2;" name="password">
|
||||||
H.p $ H.input ! A.alt "Anmelden" ! A.type_ "image" ! A.src "/static/signin.gif"
|
<p><input alt="Anmelden" type="image" src="/static/signin.gif">
|
||||||
|
|]
|
||||||
|
|
||||||
adminIndex :: Text -> Html
|
adminIndex :: Text -> Html
|
||||||
adminIndex sUser = adminTemplate "Index" $
|
adminIndex sUser = adminTemplate "Index" $ [shamlet|
|
||||||
H.div ! A.style "float: center;" $
|
<div style="float:center;">
|
||||||
H.form ! A.action "/admin/postentry" ! A.method "POST" $ do
|
<form action="/admin/postentry" method="POST">
|
||||||
H.table $ do
|
<table>
|
||||||
H.tr $ do H.td $ "Titel:"
|
<tr>
|
||||||
H.td $ H.input ! A.type_ "text" ! A.name "title"
|
<thead><td>Titel:
|
||||||
H.tr $ do H.td $ "Sprache:"
|
<td><input type="text" name="title">
|
||||||
H.td $ H.select ! A.name "lang" $ do
|
<tr>
|
||||||
H.option ! A.value "de" $ "Deutsch"
|
<thead><td>Sprache:
|
||||||
H.option ! A.value "en" $ "Englisch"
|
<td><select name="lang">
|
||||||
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Text:"
|
<option value="de">Deutsch
|
||||||
H.td $ H.textarea ! A.name "btext" ! A.cols "100" ! A.rows "15" $ mempty
|
<option value="en">Englisch
|
||||||
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Mehr Text:"
|
<tr>
|
||||||
H.td $ H.textarea ! A.name "mtext" ! A.cols "100" ! A.rows "15" $ mempty
|
<thead><td>Text:
|
||||||
H.input ! A.type_ "hidden" ! A.name "author" ! A.value (toValue sUser)
|
<td><textarea name="btext" cols="100" rows="15">
|
||||||
H.input ! A.style "margin-left: 20px" ! A.type_ "submit" ! A.value "Absenden"
|
<tr>
|
||||||
adminFooter
|
<thead><td style="vertical-align:top;">Mehr Text:
|
||||||
|
<td><textarea name="mtext" cols="100" rows="15">
|
||||||
|
<input type="hidden" name="author" value=#{sUser}>
|
||||||
|
<input style="margin-left:20px;" type="submit" value="Absenden">
|
||||||
|
#{adminFooter}
|
||||||
|
|]
|
||||||
|
|
||||||
adminFooter :: Html
|
adminFooter :: Html
|
||||||
adminFooter = H.p $ do
|
adminFooter = [shamlet|
|
||||||
preEscapedText "<a href=/>Startseite</a> -- Entrylist: <a href=/admin/entrylist/de>DE</a>"
|
<a href="/">Startseite
|
||||||
preEscapedText " & <a href=/admin/entrylist/en>EN</a> -- <a href=#>Backup</a> (NYI)"
|
/ -- Entrylist: #
|
||||||
|
<a href="/admin/entrylist/de">DE
|
||||||
|
/ & #
|
||||||
|
<a href="/admin/entrylist/en">EN
|
||||||
|
/ -- #
|
||||||
|
<a href="#">Backup
|
||||||
|
/ (NYI)
|
||||||
|
|]
|
||||||
|
|
||||||
adminEntryList :: [Entry] -> Html
|
adminEntryList :: [Entry] -> Html
|
||||||
adminEntryList entries = adminTemplate "Entrylist" $
|
adminEntryList entries = adminTemplate "EntryList" $ [shamlet|
|
||||||
H.div ! A.style "float: center;" $ do
|
<div style="float: center;">
|
||||||
H.table $ do
|
<table>
|
||||||
mapM_ showEntryItem entries
|
$forall entry <- entries
|
||||||
adminFooter
|
<tr>
|
||||||
where
|
<td><a href=#{append "/admin/edit" (show' $ entryId entry)}>#{title entry}
|
||||||
showEntryItem :: Entry -> Html
|
<td>#{formatPostDate $ edate entry}
|
||||||
showEntryItem (Entry{..}) = H.tr $ do
|
|]
|
||||||
H.td $ H.a ! A.href (toValue $ "/admin/edit/" ++ show entryId) $ toHtml title
|
where
|
||||||
H.td $ toHtml $ formatTime defaultTimeLocale "[On %D at %H:%M]" edate
|
formatPostDate = formatTime defaultTimeLocale "[On %D at %H:%M]"
|
||||||
|
|
||||||
|
|
||||||
editPage :: Entry -> Html
|
editPage :: Entry -> Html
|
||||||
editPage (Entry{..}) = adminTemplate "Index" $
|
editPage (Entry{..}) = adminTemplate "Index" $ [shamlet|
|
||||||
H.div ! A.style "float: center;" $
|
<div style="float:center;">
|
||||||
H.form ! A.action "/admin/updateentry" ! A.method "POST" $ do
|
<form action="/admin/updateentry" method="POST">
|
||||||
H.table $ do
|
<table>
|
||||||
H.tr $ do H.td $ "Titel:"
|
<tr>
|
||||||
H.td $ H.input ! A.type_ "text" ! A.name "title" ! A.value (toValue title)
|
<td>Titel:
|
||||||
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Text:"
|
<td><input type="text" name="title" value=#{title}>
|
||||||
H.td $ H.textarea ! A.name "btext" ! A.cols "100" ! A.rows "15" $ toHtml btext
|
<tr>
|
||||||
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Mehr Text:"
|
<td style="vertical-align:top;">Text:
|
||||||
H.td $ H.textarea ! A.name "mtext" ! A.cols "100" ! A.rows "15" $ toHtml mtext
|
<td><textarea name="btext" cols="100" rows="15">#{btext}
|
||||||
H.input ! A.type_ "hidden" ! A.name "eid" ! A.value (toValue $ unEntryId entryId)
|
<tr>
|
||||||
H.input ! A.style "margin-left: 20px" ! A.type_ "submit" ! A.value "Absenden"
|
<td style="vertical-align:top;">Mehr Text:
|
||||||
H.div ! A.class_ "editComments" $ editComments comments entryId
|
<td><textarea name="mtext" cols="100" rows="15">#{mtext}
|
||||||
H.p $ do preEscapedText "<a href=/>Startseite</a> -- Entrylist: <a href=/admin/entrylist/de>DE</a>"
|
<input type="hidden" name="eid" value=#{unEntryId entryId}>
|
||||||
preEscapedText " & <a href=/admin/entrylist/en>EN</a> -- <a href=#>Backup</a> (NYI)"
|
<input type="submit" style="margin-left:20px;" value="Absenden">
|
||||||
|
<div class="editComments">#{editComments comments entryId}
|
||||||
|
<p>#{adminFooter}
|
||||||
|
|]
|
||||||
|
|
||||||
editComments :: [Comment] -> EntryId -> Html
|
editComments :: [Comment] -> EntryId -> Html
|
||||||
editComments clist eId = H.table $ mapM_ editComment clist
|
editComments comments eId = [shamlet|
|
||||||
where
|
<table>
|
||||||
editComment (Comment{..}) = H.tr $ do H.td $ toHtml cauthor
|
$forall c <- comments
|
||||||
H.td $ toHtml $ formatTime defaultTimeLocale "%c" cdate
|
<tr>
|
||||||
H.td $ cDeleteLink cdate
|
<td>#{cauthor c}
|
||||||
cDeleteLink cdate = H.a ! A.href (toValue $ "/admin/cdelete/" ++ show eId
|
<td>#{cPostTime $ cdate c}
|
||||||
++ formatTime defaultTimeLocale "/%s%Q" cdate) $ "Löschen"
|
<tr>
|
||||||
|
<td><a href=#{cDeleteLink $ cdate c}>Löschen
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
cPostTime = formatTime defaultTimeLocale "%c"
|
||||||
|
cDeleteLink cd = concat ["/admin/cdelete", show eId, formatTime defaultTimeLocale "/%s%Q" cd]
|
||||||
|
|
||||||
commentDeleted :: EntryId -> Html
|
commentDeleted :: EntryId -> Html
|
||||||
commentDeleted eId = adminTemplate "Kommentar gelöscht" $ do
|
commentDeleted eId = adminTemplate "Kommentar gelöscht" $ [shamlet|
|
||||||
H.div $ "Der Kommentar wurde gelöscht."
|
<div>Der Kommentar wurde gelöscht.
|
||||||
H.br
|
<br>
|
||||||
H.a ! A.href (toValue $ "/de/" ++ show eId) $ "Eintrag ansehen | "
|
<a href=#{append "/de/" $ show' eId}>Eintrag ansehen | #
|
||||||
H.a ! A.href (toValue $ "/admin/edit/" ++ show eId) $ "Eintrag bearbeiten"
|
<a href=#{append "/admin/edit/" $ show' eId}>Eintrag bearbeiten
|
||||||
|
|]
|
||||||
|
|
||||||
-- Error pages
|
|
||||||
showError :: BlogError -> BlogLang -> Html
|
showError :: BlogError -> BlogLang -> Html
|
||||||
showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ do
|
showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ [shamlet|
|
||||||
H.span ! A.class_ "innerTitle" $ toHtml $ notFoundTitle l
|
<span class="innerTitle">#{notFoundTitle l}
|
||||||
H.div ! A.class_ "innerContainer" $ do
|
<div class="innerTitle">
|
||||||
H.p ! A.class_ "notFoundFace" $ toHtml (":'(" :: Text)
|
<p class="notFoundFace">:(
|
||||||
H.p ! A.class_ "notFoundText" $ toHtml $ notFoundText l
|
<p class="notFoundText">#{notFoundText l}
|
||||||
|
|]
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue