[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 $ "&lt;" ++ unHTML (hquote cs)
 hquote ('&':cs) = HTML $ "&amp;" ++ 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