Web framework work in progress

extra/http/server/boilerplate/boilerplate.factor

@@ -1,7 +1,8 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces boxes sequences strings
-io io.streams.string
+io io.streams.string arrays
+html.elements
 http
 http.server
 http.server.templating ;
@@ -28,6 +29,18 @@ SYMBOL: style
 : write-style ( -- )
     style get >string write ;
 
+SYMBOL: atom-feed
+
+: set-atom-feed ( title url -- )
+    2array atom-feed get >box ;
+
+: write-atom-feed ( -- )
+    atom-feed get value>> [
+        <link "alternate" =rel "application/atom+xml" =type
+        [ first =title ] [ second =href ] bi
+        link/>
+    ] when* ;
+
 SYMBOL: nested-template?
 
 SYMBOL: next-template
@@ -40,6 +53,7 @@ M: f call-template drop call-next-template ;
 : with-boilerplate ( body template -- )
     [
         title get [ <box> title set ] unless
+        atom-feed get [ <box> atom-feed set ] unless
         style get [ SBUF" " clone style set ] unless
 
         [
@@ -54,5 +68,8 @@ M: f call-template drop call-next-template ;
     ] with-scope ; inline
 
 M: boilerplate call-responder
-    [ responder>> call-responder clone ] [ template>> ] bi
+    tuck responder>> call-responder
-    [ [ with-boilerplate ] 2curry ] curry change-body ;
+    dup "content-type" header "text/html" = [
+        clone swap template>>
+        [ [ with-boilerplate ] 2curry ] curry change-body
+    ] [ nip ] if ;

extra/http/server/components/components-tests.factor

@@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ;
 [ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
 
 [ ] [ "password" <password> "p" set ] unit-test
+
+[ ] [ "pub-date" <date> "d" set ] unit-test

extra/http/server/components/components.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: html.elements http.server.validators accessors namespaces
+USING: accessors namespaces kernel io math.parser assocs classes
-kernel io math.parser assocs classes words classes.tuple arrays
+words classes.tuple arrays sequences splitting mirrors
-sequences splitting mirrors hashtables fry combinators
+hashtables fry combinators continuations math
-continuations math ;
+calendar.format html.elements
+http.server.validators ;
 IN: http.server.components
 
 ! Renderer protocol
@@ -59,9 +60,14 @@ SYMBOL: values
 
 : values-tuple values get mirror-object ;
 
+: render-view-or-summary ( component -- value renderer )
+    [ id>> value ] [ component-string ] [ renderer>> ] tri ;
+
 : render-view ( component -- )
-    [ id>> value ] [ component-string ] [ renderer>> ] tri
+    render-view-or-summary render-view* ;
-    render-view* ;
+
+: render-summary ( component -- )
+    render-view-or-summary render-summary* ;
 
 <PRIVATE
 
@@ -147,6 +153,17 @@ TUPLE: email < string ;
 M: email validate*
     call-next-method dup empty? [ v-email ] unless ;
 
+! URL fields
+TUPLE: url < string ;
+
+: <url> ( id -- component )
+    url new-string
+        5 >>min-length
+        60 >>max-length ;
+
+M: url validate*
+    call-next-method dup empty? [ v-url ] unless ;
+
 ! Don't send passwords back to the user
 TUPLE: password-renderer < field ;
 
@@ -206,20 +223,20 @@ M: captcha validate*
     drop v-captcha ;
 
 ! Text areas
-TUPLE: textarea-renderer rows cols ;
+TUPLE: text-renderer rows cols ;
 
-: new-textarea-renderer ( class -- renderer )
+: new-text-renderer ( class -- renderer )
     new
         60 >>cols
         20 >>rows ;
 
-: <textarea-renderer> ( -- renderer )
+: <text-renderer> ( -- renderer )
-    textarea-renderer new-textarea-renderer ;
+    text-renderer new-text-renderer ;
 
-M: textarea-renderer render-view*
+M: text-renderer render-view*
     drop write ;
 
-M: textarea-renderer render-edit*
+M: text-renderer render-edit*
     <textarea
         [ rows>> [ number>string =rows ] when* ]
         [ cols>> [ number>string =cols ] when* ] bi
@@ -234,11 +251,35 @@ TUPLE: text < string ;
 : new-text ( id class -- component )
     new-string
         f >>one-line
-        <textarea-renderer> >>renderer ;
+        <text-renderer> >>renderer ;
 
 : <text> ( id -- component )
     text new-text ;
 
+! HTML text component
+TUPLE: html-text-renderer < text-renderer ;
+
+: <html-text-renderer> ( -- renderer )
+    html-text-renderer new-text-renderer ;
+
+M: html-text-renderer render-view*
+    drop write ;
+
+TUPLE: html-text < text ;
+
+: <html-text> ( id -- component )
+    html-text new-text
+        <html-text-renderer> >>renderer ;
+
+! Date component
+TUPLE: date < string ;
+
+: <date> ( id -- component )
+    date new-string ;
+
+M: date component-string
+    drop timestamp>string ;
+
 ! List components
 SYMBOL: +plain+
 SYMBOL: +ordered+
@@ -248,21 +289,27 @@ TUPLE: list-renderer component type ;
 
 C: <list-renderer> list-renderer
 
-: render-list ( value component -- )
+: render-plain-list ( seq quot component -- )
-    [ render-summary* ] curry each ;
+    swap '[ , @ ] each ; inline
 
-: render-ordered-list ( value component -- )
+: render-ordered-list ( seq quot component -- )
-    [ <li> render-summary* </li> ] curry each ;
+    swap <ol> '[ <li> , @ </li> ] each </ol> ; inline
 
-: render-unordered-list ( value component -- )
+: render-unordered-list ( seq quot component -- )
-    [ <li> render-summary* </li> ] curry each ;
+    swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
+
+: render-list ( value renderer quot -- )
+    swap [ component>> ] [ type>> ] bi {
+        { +plain+     [ render-plain-list ] }
+        { +ordered+   [ render-ordered-list ] }
+        { +unordered+ [ render-unordered-list ] }
+    } case ; inline
 
 M: list-renderer render-view*
-    [ component>> ] [ type>> ] bi {
+    [ render-view* ] render-list ;
-        { +plain+ [ render-list ] }
+
-        { +ordered+ [ <ol> render-ordered-list </ol> ] }
+M: list-renderer render-summary*
-        { +unordered+ [ <ul> render-unordered-list </ul> ] }
+    [ render-summary* ] render-list ;
-    } case ;
 
 TUPLE: list < component ;
 

extra/http/server/components/farkup/farkup.factor

@@ -4,10 +4,10 @@ USING: splitting kernel io sequences farkup accessors
 http.server.components ;
 IN: http.server.components.farkup
 
-TUPLE: farkup-renderer < textarea-renderer ;
+TUPLE: farkup-renderer < text-renderer ;
 
-: <farkup-renderer>
+: <farkup-renderer> ( -- renderer )
-    farkup-renderer new-textarea-renderer ;
+    farkup-renderer new-text-renderer ;
 
 M: farkup-renderer render-view*
     drop string-lines "\n" join convert-farkup write ;

extra/http/server/forms/forms.factor

@@ -15,7 +15,8 @@ components ;
 M: form init V{ } clone >>components ;
 
 : <form> ( id -- form )
-    form f new-component ;
+    form f new-component
+        dup >>renderer ;
 
 : add-field ( form component -- form )
     dup id>> pick components>> set-at ;
@@ -68,6 +69,8 @@ M: form init V{ } clone >>components ;
         tri*
     ] with-scope ;
 
+M: form component-string drop ;
+
 M: form render-summary*
     dup summary-template>> render-form ;
 

extra/http/server/templating/chloe/chloe.factor

@@ -1,6 +1,6 @@
 USING: accessors kernel sequences combinators kernel namespaces
 classes.tuple assocs splitting words arrays
-io.files io.encodings.utf8 html.elements unicode.case
+io io.files io.encodings.utf8 html.elements unicode.case
 tuple-syntax xml xml.data xml.writer xml.utilities
 http.server
 http.server.auth
@@ -54,6 +54,19 @@ SYMBOL: tags
 : write-style-tag ( tag -- )
     drop <style> write-style </style> ;
 
+: atom-tag ( tag -- )
+    [ "title" required-attr ]
+    [ "href" required-attr ]
+    bi set-atom-feed ;
+
+: write-atom-tag ( tag -- )
+    drop
+    "head" tags get member? [
+        write-atom-feed
+    ] [
+        atom-feed get value>> second write
+    ] if ;
+
 : component-attr ( tag -- name )
     "component" required-attr ;
 
@@ -63,15 +76,20 @@ SYMBOL: tags
 : edit-tag ( tag -- )
     component-attr component render-edit ;
 
+: summary-tag ( tag -- )
+    component-attr component render-summary ;
+
 : parse-query-attr ( string -- assoc )
     dup empty?
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
 : a-start-tag ( tag -- )
     <a
-    [ "href" required-attr ]
+    dup "value" optional-attr [ value f ] [
-    [ "query" optional-attr parse-query-attr ]
+        [ "href" required-attr ]
-    bi link>string =href
+        [ "query" optional-attr parse-query-attr ]
+        bi
+    ] ?if link>string =href
     a> ;
 
 : process-tag-children ( tag -- )
@@ -126,8 +144,11 @@ SYMBOL: tags
         { "write-title" [ write-title-tag ] }
         { "style" [ style-tag ] }
         { "write-style" [ write-style-tag ] }
+        { "atom" [ atom-tag ] }
+        { "write-atom" [ write-atom-tag ] }
         { "view" [ view-tag ] }
         { "edit" [ edit-tag ] }
+        { "summary" [ summary-tag ] }
         { "a" [ a-tag ] }
         { "form" [ form-tag ] }
         { "error" [ error-tag ] }

extra/http/server/validators/validators-tests.factor

@@ -21,3 +21,9 @@ accessors ;
 
 [ "slava@factorcodeorg" v-email ]
 [ "invalid e-mail" = ] must-fail-with
+
+[ "http://www.factorcode.org" ]
+[ "http://www.factorcode.org" v-url ] unit-test
+
+[ "http:/www.factorcode.org" v-url ]
+[ "invalid URL" = ] must-fail-with

extra/http/server/validators/validators.factor

@@ -65,7 +65,12 @@ C: <validation-error> validation-error
 : v-email ( str -- str )
     #! From http://www.regular-expressions.info/email.html
     "e-mail"
-    R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i
+    R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
+    v-regexp ;
+
+: v-url ( str -- str )
+    "URL"
+    R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
     v-regexp ;
 
 : v-captcha ( str -- str )

extra/webapps/planet/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/webapps/planet/blog-summary.xml

@@ -0,0 +1,7 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:a href="view-blog" query="id"><t:view component="name" /></t:a>
+
+</t:chloe>

extra/webapps/planet/edit-blog.xml

@@ -0,0 +1,40 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Edit Blog</t:title>
+
+	<t:form action="edit-blog">
+
+		<t:edit component="id" />
+
+		<table>
+
+			<tr>
+				<th class="field-label">Blog name:</th>
+				<td><t:edit component="name" /></td>
+			</tr>
+
+			<tr>
+				<th class="field-label">Home page:</th>
+				<td><t:edit component="www-url" /></td>
+			</tr>
+
+			<tr>
+				<th class="field-label">Atom feed:</th>
+				<td><t:edit component="atom-url" /></td>
+			</tr>
+
+		</table>
+
+		<input type="SUBMIT" value="Done" />
+
+	</t:form>
+
+	<t:a href="view" query="id">View</t:a>
+	|
+	<t:form action="delete-blog" class="inline">
+		<t:edit component="id" />
+		<button type="submit" class="link-button link">Delete</button>
+	</t:form>
+</t:chloe>

extra/webapps/planet/entry-summary.xml

@@ -0,0 +1,10 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<p class="news">
+		<strong><t:view component="title" /></strong> <br/>
+		<t:a value="link" class="more">Read More...</t:a>
+	</p>
+
+</t:chloe>

extra/webapps/planet/entry.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<h2 class="posting-title"><t:view component="title" /></h2>
+	<p class="posting-body"> <t:view component="description" /> </p>
+	<p class="posting-date"> <t:view component="pub-date" /> </p>
+
+</t:chloe>

extra/webapps/planet/mini-planet.xml

@@ -0,0 +1,7 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:summary component="postings" />
+
+</t:chloe>

extra/webapps/planet/page.xml

@@ -0,0 +1,64 @@
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+	<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+		<head>
+			<t:write-title />
+
+			<t:write-atom />
+
+			<t:style>
+				.link-button {
+					padding: 0px;
+					background: none;
+					border: none;
+				}
+
+				.inline {
+					display: inline;
+				}
+
+				body, button {
+					font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+					color:#444;
+				}
+
+				a, .link {
+					color: #222;
+					border-bottom:1px dotted #666;
+					text-decoration:none;
+				}
+
+				h1 a {
+					border: none;
+				}
+
+				a:hover, .link:hover {
+					border-bottom:1px solid #66a;
+				}
+
+				.error { color: #a00; }
+				
+				.field-label {
+					text-align: right;
+				}
+			</t:style>
+
+			<t:write-style />
+		</head>
+
+		<body>
+
+			<h1><t:a href="planet"><t:write-title /></t:a></h1>
+
+			<t:call-next-template />
+		</body>
+
+	</t:chloe>
+
+</html>

extra/webapps/planet/planet.css

@@ -0,0 +1,30 @@
+h1.planet-title {
+	font-size:300%;
+}
+
+.posting-title {
+	background-color:#f5f5f5;
+}
+
+pre, code {
+	color:#000000;
+	font-size:120%;
+}
+
+.infobox {
+	border-left: 1px solid #C1DAD7;
+}
+
+.posting-date {
+	text-align: right;
+	font-size:90%;
+}
+
+a.more {
+	display:block;
+	padding:0 0 5px 0;
+	color:#333;
+	text-decoration:none;
+	text-align:right;
+	border:none;
+}

extra/webapps/planet/planet.factor

@@ -0,0 +1,174 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences sorting locals math
+calendar alarms logging concurrency.combinators
+db.types db.tuples db
+rss xml.writer
+http.server
+http.server.crud
+http.server.forms
+http.server.actions
+http.server.boilerplate
+http.server.templating.chloe
+http.server.components ;
+IN: webapps.planet
+
+TUPLE: blog id name www-url atom-url ;
+
+blog "BLOGS"
+{
+    { "id" "ID" INTEGER +native-id+ }
+    { "name" "NAME" { VARCHAR 256 } +not-null+ }
+    { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
+    { "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: init-blog-table blog ensure-table ;
+
+: <blog> ( id -- todo )
+    blog new
+        swap >>id ;
+
+: planet-template ( name -- template )
+    "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+
+: <entry-form> ( -- form )
+    "entry" <form>
+        "entry" planet-template >>view-template
+        "entry-summary" planet-template >>summary-template
+        "title" <string> add-field
+        "description" <html-text> add-field
+        "pub-date" <date> add-field ;
+
+: <blog-form> ( -- form )
+    "blog" <form>
+        "edit-blog" planet-template >>edit-template
+        "view-blog" planet-template >>view-template
+        "blog-summary" planet-template >>summary-template
+        "id" <integer>
+            hidden >>renderer
+            add-field
+        "name" <string>
+            t >>required
+            add-field
+        "www-url" <url>
+            t >>required
+            add-field
+        "atom-url" <url>
+            t >>required
+            add-field ;
+
+: <planet-factor-form> ( -- form )
+    "planet-factor" <form>
+        "planet" planet-template >>view-template
+        "mini-planet" planet-template >>summary-template
+        "postings" <entry-form> +plain+ <list> add-field
+        "blogroll" <blog-form> +unordered+ <list> add-field ;
+
+: blogroll ( -- seq )
+    f <blog> select-tuples [ [ name>> ] compare ] sort ;
+
+TUPLE: planet-factor < dispatcher postings ;
+
+:: <planet-action> ( planet -- action )
+    [let | form [ <planet-factor-form> ] |
+        <action>
+            [
+                blank-values
+
+                planet postings>> "postings" set-value
+                blogroll "blogroll" set-value
+
+                form view-form
+            ] >>display
+    ] ;
+
+: safe-head ( seq n -- seq' )
+    over length min head ;
+
+:: planet-feed ( planet -- feed )
+    feed new
+        "[ planet-factor ]" >>title
+        "http://planet.factorcode.org" >>link
+        planet postings>> 30 safe-head >>entries ;
+
+:: <feed-action> ( planet -- action )
+    <action>
+        [
+            "text/xml" <content>
+            [ planet planet-feed feed>xml write-xml ] >>body
+        ] >>display ;
+
+: <posting> ( name entry -- entry' )
+    clone [ ": " swap 3append ] change-title ;
+
+: fetch-feed ( url -- feed )
+    download-feed entries>> ;
+
+\ fetch-feed DEBUG add-error-logging
+
+: fetch-blogroll ( blogroll -- entries )
+    dup
+    [ atom-url>> fetch-feed ] parallel-map
+    [ >r name>> r> [ <posting> ] with map ] 2map concat ;
+
+: sort-entries ( entries -- entries' )
+    [ [ pub-date>> ] compare ] sort <reversed> ;
+
+: update-cached-postings ( planet -- )
+    "webapps.planet" [
+        blogroll fetch-blogroll sort-entries >>postings drop
+    ] with-logging ;
+
+:: <update-action> ( planet -- action )
+    <action>
+        [
+            planet update-cached-postings
+            "" f <temporary-redirect>
+        ] >>display ;
+
+: start-update-task ( planet -- )
+    [ update-cached-postings ] curry 10 minutes every drop ;
+
+:: <planet-factor> ( -- responder )
+    [let | blog-form [ <blog-form> ]
+           blog-ctor [ [ <blog> ] ] |
+        planet-factor new-dispatcher
+            dup <planet-action> >>default
+            dup <feed-action> "feed.xml" add-responder
+            dup <update-action> "update" add-responder
+
+            ! Administrative CRUD
+                      blog-ctor ""          <delete-action> "delete-blog" add-responder
+            blog-form blog-ctor             <view-action>   "view-blog"   add-responder
+            blog-form blog-ctor "view-blog" <edit-action>   "edit-blog"   add-responder
+    ] ;
+
+USING: namespaces io.files io.sockets
+db.sqlite smtp
+http.server.db
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db ;
+
+: test-db "planet.db" resource-path sqlite-db ;
+
+: <planet-app> ( -- responder )
+    <planet-factor>
+    <boilerplate>
+        "page" planet-template >>template
+    ! <url-sessions>
+    !     sessions-in-db >>sessions
+    test-db <db-persistence> ;
+
+: init-planet ( -- )
+    ! test-db [
+    !     init-blog-table
+        ! init-users-table
+        ! init-sessions-table
+    ! ] with-db
+
+    <dispatcher>
+        <planet-app> "planet" add-responder
+    main-responder set-global ;

extra/webapps/planet/planet.xml

@@ -0,0 +1,37 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Planet Factor</t:title>
+
+	<t:atom title="Planet Factor - Atom" href="feed.xml" />
+
+	<t:style include="resource:extra/webapps/planet/planet.css" />
+
+	<table width="100%" cellpadding="10">
+		<tr>
+			<td> <t:view component="postings" /> </td>
+
+			<td valign="top" width="25%" class="infobox">
+				<p>
+					<strong>planet-factor</strong> is an Atom feed aggregator that collects the
+					contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It was inspired by
+					<a href="http://planet.lisp.org">Planet Lisp</a>.
+				</p>
+				<p>
+					<img src="http://planet.lisp.org/feed-icon-14x14.png" />
+					<a href="feed.xml"> Syndicate </a>
+				</p>
+
+				<h2>Blogroll</h2>
+
+				<t:summary component="blogroll" />
+
+				Admin: <t:a href="edit-blog">Add Blog</t:a>
+				|
+				<t:a href="update">Update</t:a>
+			</td>
+		</tr>
+	</table>
+
+</t:chloe>

extra/webapps/planet/view-blog.xml

@@ -0,0 +1,41 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>View Blog</t:title>
+
+	<table>
+
+		<tr>
+			<th class="field-label">Blog name:</th>
+			<td><t:view component="name" /></td>
+		</tr>
+
+		<tr>
+			<th class="field-label">Home page:</th>
+			<td>
+				<t:a value="www-url">
+					<t:view component="www-url" />
+				</t:a>
+			</td>
+		</tr>
+
+		<tr>
+			<th class="field-label">Atom feed:</th>
+			<td>
+				<t:a value="atom-url">
+					<t:view component="atom-url" />
+				</t:a>
+			</td>
+		</tr>
+
+	</table>
+
+	<t:a href="edit-blog" query="id">Edit</t:a>
+	|
+	<t:form action="delete-blog" class="inline">
+		<t:edit component="id" />
+		<button type="submit" class="link-button link">Delete</button>
+	</t:form>
+
+</t:chloe>