Overhaul furnace

- validators work!
 - added sessions
 - add error checking to pastebin
 - add define-form, defalut-values

extra/furnace/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Doug Coleman

extra/furnace/furnace-tests.factor

@@ -28,7 +28,7 @@ TUPLE: test-tuple m n ;
     [
         H{
             { "bar" "hello" }
-        } \ foo query>quot
+        } \ foo query>seq
     ] with-scope
 ] unit-test
 

extra/furnace/furnace.factor

@@ -1,48 +1,39 @@
-! Copyright (C) 2006 Slava Pestov
+! Copyright (C) 2006 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel vectors io assocs quotations splitting strings 
+USING: arrays assocs debugger furnace.sessions furnace.validator
-       words sequences namespaces arrays hashtables debugger
+hashtables html.elements http http.server.responders
-       continuations tuples classes io.files 
+http.server.templating
-       http http.server.templating http.basic-authentication 
+io.files kernel namespaces quotations sequences splitting words
-       webapps.callback html html.elements 
+strings vectors webapps.callback ;
-       http.server.responders furnace.validator vocabs ;
+USING: continuations io prettyprint ;
 IN: furnace
 
-SYMBOL: default-action
+: code>quotation ( word/quot -- quot )
+    dup word? [ 1quotation ] when ;
 
+SYMBOL: default-action
 SYMBOL: template-path
 
-: define-authenticated-action ( word params realm -- )
+: render-template ( template -- )
-    pick swap "action-realm" set-word-prop
+    template-path get swap path+
+    ".furnace" append resource-path
+    run-template-file ;
+
+: define-action ( word hash -- )
     over t "action" set-word-prop
     "action-params" set-word-prop ;
 
-: define-action ( word params -- )
+: define-form ( word1 word2 hash -- )
-    f define-authenticated-action ;
+    dupd define-action
+    swap code>quotation "form-failed" set-word-prop ;
 
-: define-redirect ( word quot -- )
+: default-values ( word hash -- )
-    "action-redirect" set-word-prop ;
+    "default-values" set-word-prop ;
 
-: responder-vocab ( name -- vocab )
+SYMBOL: request-params
-    "webapps." swap append ;
+SYMBOL: current-action
-
+SYMBOL: validators-errored
-: lookup-action ( name webapp -- word )
+SYMBOL: validation-errors
-    responder-vocab lookup dup [
-        dup "action" word-prop [ drop f ] unless
-    ] when ;
-
-: truncate-url ( url -- action-name )
-  CHAR: / over index [ head ] when* ;
-
-: current-action ( url -- word/f )
-    dup empty? [ drop default-action get ] when
-    truncate-url "responder" get lookup-action ;
-
-PREDICATE: word action "action" word-prop ;
-
-: quot>query ( seq action -- hash )
-    >r >array r> "action-params" word-prop
-    [ first swap 2array ] 2map >hashtable ;
 
 : action-link ( query action -- url )
     [
@@ -52,6 +43,34 @@ PREDICATE: word action "action" word-prop ;
         word-name %
     ] "" make swap build-url ;
 
+: action-param ( hash paramsepc -- obj error/f )
+    unclip rot at swap >quotation apply-validators ;
+
+: query>seq ( hash word -- seq )
+    "action-params" word-prop [
+        dup first -rot
+        action-param [
+            t validators-errored >session
+            rot validation-errors session> set-at
+        ] [
+            nip
+        ] if*
+    ] curry* map ;
+
+: lookup-session ( hash -- session )
+    "furnace-session-id" over at* [
+        sessions get-global at
+        [ nip ] [ "furnace-session-id" over delete-at lookup-session ] if*
+    ] [
+        drop new-session rot "furnace-session-id" swap set-at
+    ] if ;
+
+: quot>query ( seq action -- hash )
+    >r >array r> "action-params" word-prop
+    [ first swap 2array ] 2map >hashtable ;
+
+PREDICATE: word action "action" word-prop ;
+
 : action-call? ( quot -- ? )
     >vector dup pop action? >r [ word? not ] all? r> and ;
 
@@ -64,62 +83,94 @@ PREDICATE: word action "action" word-prop ;
         t register-html-callback
     ] if ;
 
-: render-link ( quot name -- )
+: replace-variables ( quot -- quot )
-    <a swap quot-link =href a> write </a> ;
+    [ dup string? [ request-params session> at ] when ] map ;
 
-: action-param ( params paramspec -- obj error/f )
+: furnace-session-id ( -- hash )
-    unclip rot at swap >quotation apply-validators ;
+    "furnace-session-id" request-params session> at
+    "furnace-session-id" associate ;
 
-: query>quot ( params action -- seq )
+: redirect-to-action ( -- )
-    "action-params" word-prop [ action-param drop ] curry* map ;
+    current-action session>
+    "form-failed" word-prop replace-variables
+    quot-link furnace-session-id build-url permanent-redirect ;
 
-SYMBOL: request-params
+: if-form-page ( if then -- )
+    current-action session> "form-failed" word-prop -rot if ;
 
-: perform-redirect ( action -- )
+: do-action
-    "action-redirect" word-prop
+    current-action session> [ query>seq ] keep add >quotation call ;
-    [ dup string? [ request-params get at ] when ] map
-    [ quot-link permanent-redirect ] when* ;
 
-: (call-action) ( params action -- )
+: process-form ( -- )
-    over request-params set
+    H{ } clone validation-errors >session
-    [ query>quot ] keep [ add >quotation call ] keep
+    request-params session> current-action session> query>seq
-    perform-redirect ;
+    validators-errored session> [
+        drop redirect-to-action
+    ] [
+        current-action session> add >quotation call
+    ] if ;
 
-: call-action ( params action -- )
+: page-submitted ( -- )
-    dup "action-realm" word-prop [
+    [ process-form ] [ request-params session> do-action ] if-form-page ;
-        [ (call-action) ] with-basic-authentication
-    ] [ (call-action) ] if* ;
 
-: service-request ( params url -- )
+: action-first-time ( -- )
-    current-action [
+    request-params session> current-action session>
+    [ "default-values" word-prop swap union request-params >session ] keep
+    request-params session> do-action ;
+
+: page-not-submitted ( -- )
+    [ redirect-to-action ] [ action-first-time ] if-form-page ;
+
+: setup-call-action ( hash word -- )
+    over lookup-session session set
+    current-action >session
+    request-params session> swap union
+    request-params >session
+    f validators-errored >session ;
+
+: call-action ( hash word -- )
+    setup-call-action
+    "furnace-form-submitted" request-params session> at
+    [ page-submitted ] [ page-not-submitted ] if ;
+
+: responder-vocab ( str -- newstr )
+    "webapps." swap append ;
+
+: lookup-action ( str webapp -- word )
+    responder-vocab lookup dup [
+        dup "action" word-prop [ drop f ] unless
+    ] when ;
+
+: truncate-url ( str -- newstr )
+    CHAR: / over index [ head ] when* ;
+
+: parse-action ( str -- word/f )
+    dup empty? [ drop default-action get ] when
+    truncate-url "responder" get lookup-action ;
+
+: service-request ( hash str -- )
+    parse-action [
         [ call-action ] [ <pre> print-error </pre> ] recover
     ] [
         "404 no such action: " "argument" get append httpd-error
     ] if* ;
 
-: service-get ( url -- ) "query" get swap service-request ;
+: service-get
+    "query" get swap service-request ;
 
-: service-post ( url -- ) "response" get swap service-request ;
+: service-post
+    "response" get swap service-request ;
 
-: send-resource ( name -- )
+: web-app ( name defaul path -- )
-    template-path get swap path+ resource-path <file-reader>
-    stdio get stream-copy ;
-
-: render-template ( template -- )
-    template-path get swap path+
-    ".furnace" append resource-path
-    run-template-file ;
-
-: web-app ( name default path -- )
     [
         template-path set
         default-action set
         "responder" set
         [ service-get ] "get" set
         [ service-post ] "post" set
-        ! [ service-head ] "head" set
     ] make-responder ;
 
+USING: classes html tuples vocabs ;
 : explode-tuple ( tuple -- )
     dup tuple-slots swap class "slot-names" word-prop
     [ set ] 2each ;
@@ -138,3 +189,24 @@ SYMBOL: model
     <a f >vocab-link browser-link-href =href a>
         "Browse source" write
     </a> ;
+
+: send-resource ( name -- )
+    template-path get swap path+ resource-path <file-reader>
+    stdio get stream-copy ;
+
+: render-link ( quot name -- )
+    <a swap quot-link =href a> write </a> ;
+
+: session-var ( str -- newstr )
+    request-params session> at ;
+
+: render ( str -- )
+    request-params session> at [ write ] when* ;
+
+: render-error ( str error-str -- )
+    swap validation-errors session> at validation-error? [
+        write
+    ] [
+        drop
+    ] if ;
+

extra/furnace/sessions/sessions.factor

@@ -0,0 +1,31 @@
+USING: assocs calendar init kernel math.parser namespaces random ;
+IN: furnace.sessions
+
+SYMBOL: sessions
+
+[ H{ } clone sessions set-global ] "furnace.sessions" add-init-hook
+
+: new-session-id ( -- str )
+    1 big-random number>string ;
+
+TUPLE: session created last-seen user-agent namespace ;
+
+: <session> ( -- obj )
+    now dup H{ } clone
+    [ set-session-created set-session-last-seen set-session-namespace ]
+    \ session construct ;
+
+: new-session ( -- obj id )
+    <session> new-session-id [ sessions get-global set-at ] 2keep ;
+
+: get-session ( id -- obj/f )
+    sessions get-global at* [ "no session found 1" throw ] unless ;
+
+: destroy-session ( id -- )
+    sessions get-global delete-at ;
+
+: session> ( str -- obj )
+    session get session-namespace at ;
+
+: >session ( value key -- )
+    session get session-namespace set-at ;

extra/http/http.factor

@@ -60,11 +60,18 @@ IN: http
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make ;
 
-: build-url ( path query-params -- str )
+: hash>query ( hash -- str )
+    [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
+    "&" join ;
+
+: build-url ( str query-params -- newstr )
     [
-        swap % dup assoc-empty? [
+        over %
-            "?" % dup
+        dup assoc-empty? [
-            [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
+            2drop
-            "&" join %
+        ] [
-        ] unless drop
+            CHAR: ? rot member? "&" "?" ? %
+            hash>query %
+        ] if
     ] "" make ;
+    

extra/webapps/pastebin/annotate-paste.furnace

@@ -6,16 +6,16 @@
 
 <table>
 
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-
 <tr>
 <th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
 </tr>
 
 <tr>
 <th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
+<td><input type="TEXT" name="author" value="<% "author" render  %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
 </tr>
 
 <tr>
@@ -23,11 +23,25 @@
 <td><% "modes" render-template %></td>
 </tr>
 
+<!--
+<tr>
+<th align="right">Channel:</th>
+<td><input type="TEXT" name="channel" value="#concatenative" /></td>
+</tr>
+-->
+
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
 <tr>
 <th align="right" valign="top">Content:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
 </tr>
 </table>
 
+<input type="hidden" name="n" value="<% "n" get number>string write %>" />
+<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
 <input type="SUBMIT" value="Annotate" />
 </form>

extra/webapps/pastebin/modes.furnace

@@ -1,7 +1,7 @@
-<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %>
+<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
 
 <select name="mode">
     <% modes keys natural-sort [
-        <option dup "factor" = [ "true" =selected ] when option> write </option>
+        <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
     ] each %>
 </select>

extra/webapps/pastebin/new-paste.furnace

@@ -1,4 +1,4 @@
-<% USING: furnace namespaces ; %>
+<% USING: continuations furnace namespaces ; %>
 
 <%
     "New paste" "title" set
@@ -11,12 +11,14 @@
 
 <tr>
 <th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
 </tr>
 
 <tr>
 <th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
+<td><input type="TEXT" name="author" value="<% "author" render  %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
 </tr>
 
 <tr>
@@ -31,12 +33,18 @@
 </tr>
 -->
 
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
 <tr>
 <th align="right" valign="top">Content:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
 </tr>
 </table>
 
+<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
 <input type="SUBMIT" value="Submit paste" />
 </form>
 

extra/webapps/pastebin/pastebin.factor

@@ -84,28 +84,37 @@ C: <annotation> annotation
         store save-store
     ] keep paste-link permanent-redirect ;
 
+\ new-paste
 \ submit-paste {
-    { "summary" "- no summary -" v-default }
+    { "summary" v-required }
-    { "author" "- no author -" v-default }
+    { "author" v-required }
-    { "channel" "#concatenative" v-default }
+    { "channel" }
-    { "mode" "factor" v-default }
+    { "mode" v-required }
     { "contents" v-required }
-} define-action
+} define-form
+
+\ new-paste {
+    { "channel" "#concatenative" }
+    { "mode" "factor" }
+} default-values
 
 : annotate-paste ( n summary author mode contents -- )
     <annotation> swap get-paste
-    paste-annotations push
+    [ paste-annotations push store save-store ] keep
-    store save-store ;
+    paste-link permanent-redirect ;
 
+[ "n" show-paste ]
 \ annotate-paste {
     { "n" v-required v-number }
-    { "summary" "- no summary -" v-default }
+    { "summary" v-required }
-    { "author" "- no author -" v-default }
+    { "author" v-required }
-    { "mode" "factor" v-default }
+    { "mode" v-required }
     { "contents" v-required }
-} define-action
+} define-form
 
-\ annotate-paste [ "n" show-paste ] define-redirect
+\ show-paste {
+    { "mode" "factor" }
+} default-values
 
 : style.css ( -- )
     "text/css" serving-content

extra/webapps/pastebin/style.css

@@ -35,3 +35,7 @@ pre.code {
 	border: 1px solid #C1DAD7;
 	padding: 10px;
 }
+
+.error {
+	color: red;
+}