Working on blogs web app

extra/db/tuples/tuples.factor

@@ -149,6 +149,9 @@ M: retryable execute-statement* ( statement type -- )
 : select-tuples ( tuple -- tuples )
     dup dup class <select-by-slots-statement> do-select ;
 
+: count-tuples ( tuple -- n )
+    select-tuples length ;
+
 : select-tuple ( tuple -- tuple/f )
     dup dup class f f f 1 <advanced-select-statement>
     do-select ?first ;

extra/furnace/furnace.factor

@@ -151,7 +151,7 @@ CHLOE: a
 : form-magic ( tag -- )
     [ modify-form ] each-responder
     nested-values get " " join f like form-nesting-key hidden-form-field
-    "for" optional-attr [ hidden render ] when* ;
+    "for" optional-attr [ "," split [ hidden render ] each ] when* ;
 
 : form-start-tag ( tag -- )
     [

extra/urls/urls-tests.factor

@@ -1,7 +1,7 @@
 IN: urls.tests
 USING: urls urls.private tools.test
 tuple-syntax arrays kernel assocs
-present ;
+present accessors ;
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
 [ "hello world" ] [ "hello%20world" url-decode ] unit-test
@@ -224,3 +224,5 @@ urls [
 [ "a" ] [
     <url> "a" "b" set-query-param "b" query-param
 ] unit-test
+
+[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test

extra/urls/urls.factor

@@ -170,7 +170,7 @@ M: url present
             [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
             [ path>> url-encode % ]
             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
-            [ anchor>> [ "#" % url-encode % ] when* ]
+            [ anchor>> [ "#" % present url-encode % ] when* ]
         } cleave
     ] "" make ;
 

extra/webapps/blogs/blogs-common.xml

@@ -0,0 +1,31 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:atom t:href="$blogs/posts.atom">Recent Posts</t:atom>
+
+	<t:style t:include="resource:extra/webapps/blogs/blogs.css" />
+
+	<div class="navbar">
+
+		  <t:a t:href="$blogs/">All Posts</t:a>
+		| <t:a t:href="$blogs/by">My Posts</t:a>
+		| <t:a t:href="$blogs/new-post">New Post</t:a>
+
+		<t:if t:code="furnace.sessions:uid">
+
+			<t:if t:code="furnace.auth.login:allow-edit-profile?">
+				| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+			</t:if>
+
+			| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+
+		</t:if>
+
+	</div>
+
+	<h2><t:write-title /></h2>
+
+	<t:call-next-template />
+
+</t:chloe>

extra/webapps/blogs/blogs.css

@@ -0,0 +1,15 @@
+.post-form {
+	border: 2px solid #666;
+	padding: 10px;
+	background: #eee;
+}
+
+.post-title {
+	background-color:#f5f5ff;
+	padding: 3px;
+}
+
+.post-footer {
+	text-align: right;
+	font-size:90%;
+}

extra/webapps/blogs/blogs.factor

@@ -0,0 +1,253 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences sorting math.order math.parser
+urls validators html.components db.types db.tuples calendar
+http.server.dispatchers
+furnace furnace.actions furnace.auth.login furnace.boilerplate
+furnace.sessions furnace.syndication ;
+IN: webapps.blogs
+
+TUPLE: blogs < dispatcher ;
+
+: view-post-url ( id -- url )
+    number>string "$blogs/post/" prepend >url ;
+
+: view-comment-url ( parent id -- url )
+    [ view-post-url ] dip >>anchor ;
+
+: list-posts-url ( -- url )
+    URL" $blogs/" ;
+
+: user-posts-url ( author -- url )
+    "$blogs/by/" prepend >url ;
+
+TUPLE: entity id author date content ;
+
+GENERIC: entity-url ( entity -- url )
+
+M: entity feed-entry-url entity-url ;
+
+entity f {
+    { "id" "ID" INTEGER +db-assigned-id+ }
+    { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
+    { "date" "DATE" TIMESTAMP +not-null+ }
+    { "content" "CONTENT" TEXT +not-null+ }
+} define-persistent
+
+M: entity feed-entry-date date>> ;
+
+TUPLE: post < entity title comments ;
+
+M: post feed-entry-title
+    [ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
+
+M: post entity-url
+    id>> view-post-url ;
+
+\ post "BLOG_POSTS" {
+    { "title" "TITLE" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: <post> ( id -- post ) \ post new swap >>id ;
+
+: init-posts-table \ post ensure-table ;
+
+TUPLE: comment < entity parent ;
+
+comment "COMMENTS" {
+    { "parent" "PARENT" INTEGER +not-null+ } ! post id
+} define-persistent
+
+M: comment feed-entry-title
+    author>> "Comment by " prepend ;
+
+M: comment entity-url
+    [ parent>> ] [ id>> ] bi view-comment-url ;
+
+: <comment> ( parent id -- post )
+    comment new
+        swap >>id
+        swap >>parent ;
+
+: init-comments-table comment ensure-table ;
+
+: post ( id -- post )
+    [ <post> select-tuple ] [ f <comment> select-tuples ] bi
+    >>comments ;
+
+: reverse-chronological-order ( seq -- sorted )
+    [ [ date>> ] compare invert-comparison ] sort ;
+
+: validate-author ( -- )
+    { { "author" [ [ v-username ] v-optional ] } } validate-params ;
+
+: list-posts ( -- posts )
+    f <post> "author" value >>author
+    select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
+    reverse-chronological-order ;
+
+: <list-posts-action> ( -- action )
+    <page-action>
+        [
+            list-posts "posts" set-value
+        ] >>init
+
+        { blogs "list-posts" } >>template ;
+
+: <list-posts-feed-action> ( -- action )
+    <feed-action>
+        [ "Recent Posts" ] >>title
+        [ list-posts ] >>entries
+        [ list-posts-url ] >>url ;
+
+: <user-posts-action> ( -- action )
+    <page-action>
+        "author" >>rest
+        [
+            validate-author
+            list-posts "posts" set-value
+        ] >>init
+        { blogs "user-posts" } >>template ;
+
+: <user-posts-feed-action> ( -- action )
+    <feed-action>
+        [ validate-author ] >>init
+        [ "Recent Posts by " "author" value append ] >>title
+        [ list-posts ] >>entries
+        [ "author" value user-posts-url ] >>url ;
+
+: <post-feed-action> ( -- action )
+    <feed-action>
+        [ validate-integer-id "id" value post "post" set-value ] >>init
+        [ "post" value feed-entry-title ] >>title
+        [ "post" value entity-url ] >>url
+        [ "post" value comments>> ] >>entries ;
+
+: <view-post-action> ( -- action )
+    <page-action>
+        "id" >>rest
+
+        [
+            validate-integer-id
+            "id" value post from-object
+
+            "id" value
+            "new-comment" [
+                "parent" set-value
+            ] nest-values
+        ] >>init
+
+        { blogs "view-post" } >>template ;
+
+: validate-post ( -- )
+    {
+        { "title" [ v-one-line ] }
+        { "content" [ v-required ] }
+    } validate-params ;
+
+: <new-post-action> ( -- action )
+    <page-action>
+        [
+            validate-post
+            uid "author" set-value
+        ] >>validate
+
+        [
+            f <post>
+                dup { "title" "content" } deposit-slots
+                uid >>author
+                now >>date
+            [ insert-tuple ] [ entity-url <redirect> ] bi
+        ] >>submit
+
+        { blogs "new-post" } >>template ;
+
+: <edit-post-action> ( -- action )
+    <page-action>
+        [
+            validate-integer-id
+            "id" value <post> select-tuple from-object
+        ] >>init
+
+        [
+            validate-integer-id
+            validate-post
+        ] >>validate
+
+        [
+            "id" value <post> select-tuple
+                dup { "title" "content" } deposit-slots
+            [ update-tuple ] [ entity-url <redirect> ] bi
+        ] >>submit
+
+        { blogs "edit-post" } >>template ;
+    
+: <delete-post-action> ( -- action )
+    <action>
+        [
+            validate-integer-id
+            { { "author" [ v-username ] } } validate-params
+        ] >>validate
+        [
+            "id" value <post> delete-tuples
+            "author" value user-posts-url <redirect>
+        ] >>submit ;
+
+: validate-comment ( -- )
+    {
+        { "parent" [ v-integer ] }
+        { "content" [ v-required ] }
+    } validate-params ;
+
+: <new-comment-action> ( -- action )
+    <action>
+
+        [
+            validate-comment
+            uid "author" set-value
+        ] >>validate
+
+        [
+            "parent" value f <comment>
+                "content" value >>content
+                uid >>author
+                now >>date
+            [ insert-tuple ] [ entity-url <redirect> ] bi
+        ] >>submit ;
+    
+: <delete-comment-action> ( -- action )
+    <action>
+        [
+            validate-integer-id
+            { { "parent" [ v-integer ] } } validate-params
+        ] >>validate
+        [
+            f "id" value <comment> delete-tuples
+            "parent" value view-post-url <redirect>
+        ] >>submit ;
+    
+: <blogs> ( -- dispatcher )
+    blogs new-dispatcher
+        <list-posts-action> "" add-responder
+        <list-posts-feed-action> "posts.atom" add-responder
+        <user-posts-action> "by" add-responder
+        <user-posts-feed-action> "by.atom" add-responder
+        <view-post-action> "post" add-responder
+        <post-feed-action> "post.atom" add-responder
+        <new-post-action> <protected>
+            "make a new blog post" >>description
+            "new-post" add-responder
+        <edit-post-action> <protected>
+            "edit a blog post" >>description
+            "edit-post" add-responder
+        <delete-post-action> <protected>
+            "delete a blog post" >>description
+            "delete-post" add-responder
+        <new-comment-action> <protected>
+            "make a comment" >>description
+            "new-comment" add-responder
+        <delete-comment-action> <protected>
+            "delete a comment" >>description
+            "delete-comment" add-responder
+    <boilerplate>
+        { blogs "blogs-common" } >>template ;

extra/webapps/blogs/edit-post.xml

@@ -0,0 +1,29 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Edit: <t:label t:name="title" /></t:title>
+
+	<div class="post-form">
+		<t:form t:action="$blogs/edit-post" t:for="id">
+
+			<p>Title: <t:field t:name="title" t:size="60" /></p>
+			<p><t:textarea t:name="content" t:rows="30" t:cols="80" /></p>
+			<input type="SUBMIT" value="Done" />
+		</t:form>
+	</div>
+
+	<div class="posting-footer">
+		Post by
+		<t:a t:href="$blogs/" t:query="author">
+			<t:label t:name="author" />
+		</t:a>
+		on
+		<t:label t:name="date" />
+		|
+		<t:a t:href="$blogs/post" t:for="id">View Post</t:a>
+		|
+		<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
+	</div>
+
+</t:chloe>

extra/webapps/blogs/list-posts.xml

@@ -0,0 +1,35 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Recent Posts</t:title>
+
+	<t:bind-each t:name="posts">
+
+		<h2 class="post-title">
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="title" />
+			</t:a>
+		</h2>
+
+		<p class="posting-body">
+			<t:farkup t:name="content" />
+		</p>
+
+		<div class="posting-footer">
+			Post by
+			<t:a t:href="$blogs/by" t:query="author">
+				<t:label t:name="author" />
+			</t:a>
+			on
+			<t:label t:name="date" />
+			|
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="comments" />
+				comments.
+			</t:a>
+		</div>
+
+	</t:bind-each>
+
+</t:chloe>

extra/webapps/blogs/new-post.xml

@@ -0,0 +1,17 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New Post</t:title>
+
+	<div class="post-form">
+		<t:form t:action="$blogs/new-post">
+	
+			<p>Title: <t:field t:name="title" t:size="60" /></p>
+			<p><t:textarea t:name="content" t:rows="30" t:cols="80" /></p>
+			<input type="SUBMIT" value="Done" />
+		</t:form>
+	</div>
+
+	<t:validation-messages />
+</t:chloe>

extra/webapps/blogs/user-posts.xml

@@ -0,0 +1,41 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:atom t:href="$blogs/by" t:query="author">
+		Recent Posts by <t:label t:name="author" />
+	</t:atom>
+
+	<t:title>
+		Recent Posts by <t:label t:name="author" />
+	</t:title>
+
+	<t:bind-each t:name="posts">
+
+		<h2 class="post-title">
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="title" />
+			</t:a>
+		</h2>
+
+		<p class="posting-body">
+			<t:farkup t:name="content" />
+		</p>
+
+		<div class="posting-footer">
+			Post by
+			<t:a t:href="$blogs/by" t:query="author">
+				<t:label t:name="author" />
+			</t:a>
+			on
+			<t:label t:name="date" />
+			|
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="comments" />
+				comments.
+			</t:a>
+		</div>
+
+	</t:bind-each>
+
+</t:chloe>

extra/webapps/blogs/view-post.xml

@@ -0,0 +1,60 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:atom t:href="$blogs/post.atom" t:query="id">
+		<t:label t:name="author" />: <t:label t:name="title" />
+	</t:atom>
+
+	<t:atom t:href="$blogs/by" t:query="author">
+		Recent Posts by <t:label t:name="author" />
+	</t:atom>
+
+	<t:title> <t:label t:name="title" /> </t:title>
+
+	<p class="posting-body">
+		<t:farkup t:name="content" />
+	</p>
+
+	<div class="posting-footer">
+		Post by
+		<t:a t:href="$blogs/" t:query="author">
+			<t:label t:name="author" />
+		</t:a>
+		on
+		<t:label t:name="date" />
+		|
+		<t:a t:href="$blogs/edit-post" t:query="id">Edit Post</t:a>
+		|
+		<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
+	</div>
+
+	<t:bind-each t:name="comments">
+		<hr/>
+
+		<p class="comment-header">
+			Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
+		</p>
+
+		<p class="posting-body">
+			<t:farkup t:name="content" />
+		</p>
+		
+		<t:button t:action="$blogs/delete-comment" t:for="id,parent" class="link-button link">Delete Comment</t:button>
+
+	</t:bind-each>
+
+	<t:bind t:name="new-comment">
+
+		<h2>New Comment</h2>
+
+		<div class="post-form">
+			<t:form t:action="$blogs/new-comment" t:for="parent">
+				<p><t:textarea t:name="content" t:rows="20" t:cols="60" /></p>
+				<p><input type="SUBMIT" value="Done" /></p>
+			</t:form>
+		</div>
+
+	</t:bind>
+
+</t:chloe>

extra/webapps/factor-website/factor-website.factor

@@ -12,6 +12,7 @@ furnace.sessions
 furnace.auth.login
 furnace.auth.providers.db
 furnace.boilerplate
+webapps.blogs
 webapps.pastebin
 webapps.planet
 webapps.todo
@@ -38,13 +39,17 @@ IN: webapps.factor-website
         init-articles-table
         init-revisions-table
 
+        init-postings-table
+        init-comments-table
+
         init-short-url-table
     ] with-db ;
 
 TUPLE: factor-website < dispatcher ;
 
 : <factor-website> ( -- responder )
-    factor-website new-dispatcher 
+    factor-website new-dispatcher
+        <blogs> "blogs" add-responder
         <todo-list> "todo" add-responder
         <pastebin> "pastebin" add-responder
         <planet-factor> "planet" add-responder

extra/webapps/pastebin/paste.xml

@@ -53,6 +53,7 @@
 			</table>
 
 			<input type="SUBMIT" value="Done" />
+
 		</t:form>
 
 	</t:bind>

extra/webapps/planet/planet.xml

@@ -19,7 +19,7 @@
 					</p>
 
 					<p class="posting-date">
-						<t:a t:value="url"><t:label t:name="pub-date" /></t:a>
+						<t:a t:value="url"><t:label t:name="date" /></t:a>
 					</p>
 
 				</t:bind-each>

extra/webapps/todo/todo.factor

@@ -51,6 +51,9 @@ todo "TODO"
         { "description" [ v-required ] }
     } validate-params ;
 
+: view-todo-url ( id -- url )
+    <url> "$todo-list/view" >>path swap "id" set-query-param ;
+
 : <new-action> ( -- action )
     <page-action>
         [ 0 "priority" set-value ] >>init
@@ -62,14 +65,7 @@ todo "TODO"
         [
             f <todo>
                 dup { "summary" "priority" "description" } deposit-slots
-            [ insert-tuple ]
+            [ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
-            [
-                <url>
-                    "$todo-list/view" >>path
-                    swap id>> "id" set-query-param
-                <redirect>
-            ]
-            bi
         ] >>submit ;
 
 : <edit-action> ( -- action )
@@ -89,23 +85,19 @@ todo "TODO"
         [
             f <todo>
                 dup { "id" "summary" "priority" "description" } deposit-slots
-            [ update-tuple ]
+            [ update-tuple ] [ id>> view-todo-url <redirect> ] bi
-            [
-                <url>
-                    "$todo-list/view" >>path
-                    swap id>> "id" set-query-param
-                <redirect>
-            ]
-            bi
         ] >>submit ;
 
+: todo-list-url ( -- url )
+    URL" $todo-list/list" ;
+
 : <delete-action> ( -- action )
     <action>
         [ validate-integer-id ] >>validate
 
         [
             "id" get <todo> delete-tuples
-            URL" $todo-list/list" <redirect>
+            todo-list-url <redirect>
         ] >>submit ;
 
 : <list-action> ( -- action )

extra/webapps/wiki/wiki.factor

@@ -15,14 +15,14 @@ validators
 db.types db.tuples lcs farkup urls ;
 IN: webapps.wiki
 
-: title-url ( title action -- url )
+: view-url ( title -- url )
-    "$wiki/" prepend >url swap "title" set-query-param ;
+    "$wiki/view/" prepend >url ;
 
-: view-url ( title -- url ) "view" title-url ;
+: edit-url ( title -- url )
+    "$wiki/edit" >url swap "title" set-query-param ;
 
-: edit-url ( title -- url ) "edit" title-url ;
+: revisions-url ( title -- url )
-
+    "$wiki/revisions" >url swap "title" set-query-param ;
-: revisions-url ( title -- url ) "revisions" title-url ;
 
 : revision-url ( id -- url )
     "$wiki/revision" >url swap "id" set-query-param ;