module HtmlPostComment (htmlPostComment) where
import Network.SimpleCGI
import Text.XHtml
import PageTemplate
import Session
import Blob
import Control.Monad
import Data.List (isPrefixOf)
import Data.Maybe
doHtmlPostComment :: Database -> Session -> CGI CGIResult
doHtmlPostComment db sess =
do
e <- readInput "entryid"
p <- readInput "parentid"
t <- getInput "title"
d <- getInput "text"
case (e,t,d) of
(Just eid, Just title, Just text) ->
do
cid <- io (addComment db eid p (Just $ sessionUser sess) title text)
funRedirect "view" [("entryid", show eid)]
_ -> htmlPostCommentPage db sess
htmlPostCommentPage :: Database -> Session -> CGI CGIResult
htmlPostCommentPage db sess =
do
mentryid <- readInput "entryid"
mparid <- readInput "parentid"
let entryid = fromJust mentryid -- FIXME
mentry <- io (getEntry db entryid)
let entry = fromJust mentry -- FIXME
mpar <- io (maybe (return Nothing) (getComment db) mparid)
showPage (Just sess) "Post a comment"
(h1 << "Post a comment" +++ postCommentForm entry mpar)
postCommentForm :: Entry -> Maybe Comment -> Html
postCommentForm entry mpar =
blobForm << (hs +++ hidden "fun" "postcomment"
+++ formRow "Title" (textfield "title" ! [value (title mpar)])
+++ formRow "Content" (textarea ! [name "text",rows "10",cols "40"] << "")
+++ formRow "" (submit "submit" "Submit"))
where hs = [hidden "parentid" (show (cid c)) | c <- maybeToList mpar]
++ [hidden "entryid" (show (eid entry))]
title Nothing = addRe $ esubject entry
title (Just par) = addRe $ csubject par
addRe s = if "Re:" `isPrefixOf` s then s else "Re: " ++ s
htmlPostComment :: Database -> CGI CGIResult
htmlPostComment db = withLogin db (doHtmlPostComment db) (destVars >>= funRedirect "login")