[Fencommits] fenserve: show edit and reply forms in blog demo (handling POST not implemented yet)
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 21:27:48 EET 2007
Thu Mar 22 21:27:22 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* show edit and reply forms in blog demo (handling POST not implemented yet)
diff -rN -u old-fenserve/Page.stub new-fenserve/Page.stub
--- old-fenserve/Page.stub 2007-03-22 21:27:47.000000000 +0200
+++ new-fenserve/Page.stub 2007-03-22 21:27:47.000000000 +0200
@@ -13,9 +13,14 @@
pageHandler :: HTML -> Handler
pageHandler html _request =
return $ mkResult 200 "text/html" (toUTF $ unHTML html)
+
+lookWithDefault param dflt req = fromMaybe dflt $ lookM req param
newtype HTML = HTML { unHTML :: String } deriving (Show,Read,Eq,Ord)
+(+++) :: (ToXML a, ToXML b) => a -> b -> HTML
+x +++ y = HTML (unHTML (toXMLs x) ++ unHTML (toXMLs y))
+
hquote :: String -> HTML
hquote ('<':cs) = HTML $ "<" ++ unHTML (hquote cs)
hquote ('&':cs) = HTML $ "&" ++ unHTML (hquote cs)
diff -rN -u old-fenserve/board-demo.page new-fenserve/board-demo.page
--- old-fenserve/board-demo.page 2007-03-22 21:27:47.000000000 +0200
+++ new-fenserve/board-demo.page 2007-03-22 21:27:47.000000000 +0200
@@ -1,6 +1,9 @@
import Fenfire.RDF
+import qualified Data.List as List
+import Data.Maybe (fromMaybe)
+
dc = "http://purl.org/dc/elements/1.1/"
dcterms = "http://purl.org/dc/terms/"
sioc = "http://rdfs.org/sioc/ns#"
@@ -35,8 +38,7 @@
(blog, dc_title, lit "Benja's Blog"),
(blog, dc_description, lit "Benja Fallenstein"),
(post, dc_title, lit "Hi there!"),
- (post, content_encoded, lit $ <div><p>Well, I'm blogging, ain't I?</p>
- <p>Yep, sure am, sure am.</p></div>),
+ (post, content_encoded, lit $ unHTML $ <p>Test post. <i>All cool.</i></p>),
(post, dcterms_created, lit "someday"),
(post, dcterms_modified, lit "someday"),
(post, dc_creator, lit "Benja"),
@@ -45,19 +47,19 @@
blockquote html = <blockquote><% html %></blockquote>
renderPost :: (?graph :: Graph) => Node -> HTML
-renderPost p = let replyURI = "/post?inReplyTo=" ++ iriStr p
- editURI = "/edit?post=" ++ iriStr p in
+renderPost p = let replyURI = "?view=post&inReplyTo=" ++ iriStr p
+ editURI = "?view=edit&post=" ++ iriStr p in
<div>
<h2><% postTitle p %> (<a href=editURI><i>Edit this</i></a> | <a
href=replyURI><i>Reply to this</i></a>)</h2>
<p>Posted by <b><i><% postAuthor p %></i></b> on <% postDate p %></p>
- <% postContent p %>
- <% concatMap (blockquote . renderPost) (postReplies p) %>
+ <% HTML (postContent p) %>
+ <% map (blockquote . renderPost) (postReplies p) %>
</div>
renderBoard :: (?graph :: Graph) => Node -> HTML
renderBoard b = simplePage (boardTitle b) $
- boardDesc b ++ concatMap ((<hr/> ++) . renderPost) (boardPosts b)
+ boardDesc b +++ map ((<hr/> +++) . renderPost) (boardPosts b)
simplePage title body =
<html>
@@ -68,8 +70,43 @@
</body>
</html>
+-- dummy arguments because GHC wants to apply the monomorphism restriction
+-- even though I'm giving a type signature (yikes!)
+postForm :: (?graph :: Graph, ?req :: Request) => () -> HTML
+postForm () = let addRe s | "Re:" `List.isPrefixOf` s = s
+ | otherwise = "Re: " ++ s
+ title = maybe "" (\irt -> addRe $ postTitle $ IRI irt)
+ (lookM ?req "inReplyTo") in
+ <form action="" method="POST">
+ <p><b>Title:</b> <input type="text" name="title" value=title/></p>
+ <p><b>Your name:</b> <input type="text" name="author"/></p>
+ <% maybe (HTML "")
+ (\irt -> <input type="hidden" name="inReplyTo" value=irt/>)
+ (lookM ?req "inReplyTo") %>
+ <p><textarea name="content" rows="10" cols="70"></textarea></p>
+ <p><input type="submit"/></p>
+ </form>
+
+editForm :: (?graph :: Graph, ?req :: Request) => () -> HTML
+editForm () = let post = IRI (lookWithDefault "post" "ex:post" ?req) in
+ <form action="" method="POST">
+ <p><b>Title:</b> <input type="text" name="title"
+ value=(postTitle post)/></p>
+ <p><b>Your name:</b> <input type="text" name="author"
+ value=(postAuthor post)/></p>
+ <input type="hidden" name="post" value=(iriStr post)/>
+ <p><textarea name="content" rows="10" cols="70">
+ <% postContent post %></textarea></p>
+ <p><input type="submit"/></p>
+ </form>
+
handler req = do
e <- getEntry ["testdata","blog"]
- graph <- case e of Right (FileEntry _ r) -> readGraph (bID r)
+ graph <- case e of Right (FileEntry r) -> readGraph (bID r)
_ -> return example
- flip pageHandler req $ let ?graph = graph in renderBoard blog
+
+ let ?graph = graph; ?req = req in
+ case (lookM req "view", rqMethod req) of
+ (Just "post", GET) -> pageHandler (postForm ()) req
+ (Just "edit", GET) -> pageHandler (editForm ()) req
+ _ -> flip pageHandler req $ let ?graph = graph in renderBoard blog
diff -rN -u old-fenserve/edit-demo.page new-fenserve/edit-demo.page
--- old-fenserve/edit-demo.page 2007-03-22 21:27:47.000000000 +0200
+++ new-fenserve/edit-demo.page 2007-03-22 21:27:47.000000000 +0200
@@ -5,7 +5,7 @@
import Data.Maybe (fromMaybe)
handler req = do
- let uri = fromMaybe "/testdata/foo" $ lookM req "uri"
+ let uri = lookWithDefault "uri" "/testdata/foo" req
if rqMethod req == POST
then case lookM req "contents" of
More information about the Fencommits
mailing list