Working on furnace

contrib/furnace-pastebin/annotate-paste.fhtml

@@ -0,0 +1,28 @@
+<% USING: namespaces math io ; %>
+
+<h1>Annotate</h1>
+
+<form method="POST" action="/responder/pastebin/annotate-paste">
+
+<table>
+
+<input type="hidden" name="n" value="<% "n" get number>string write %>" />
+
+<tr>
+<th>Summary:</th>
+<td><input type="TEXT" name="summary" value="" /></td>
+</tr>
+
+<tr>
+<th>Your name:</th>
+<td><input type="TEXT" name="author" value="" /></td>
+</tr>
+
+<tr>
+<th valign="top">Contents:</th>
+<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+</tr>
+</table>
+
+<input type="SUBMIT" value="Annotate" />
+</form>

contrib/furnace-pastebin/annotation.fhtml

@@ -0,0 +1,11 @@
+<% USING: namespaces io ; %>
+
+<h2>Annotation: <% "summary" get write %></h2>
+
+<table>
+<tr><th>Annotation by:</th><td><% "author" get write %></td></tr>
+<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
+<tr><th>Created:</th><td><% "date" get write %></td></tr>
+</table>
+
+<pre><% "contents" get write %></pre>

contrib/furnace-pastebin/new-paste.fhtml

@@ -12,6 +12,11 @@
 <td><input type="TEXT" name="author" value="" /></td>
 </tr>
 
+<tr>
+<th>Channel:</th>
+<td><input type="TEXT" name="channel" value="" /></td>
+</tr>
+
 <tr>
 <th valign="top">Contents:</th>
 <td><textarea rows="24" cols="60" name="contents"></textarea></td>

contrib/furnace-pastebin/pastebin.factor

@@ -2,11 +2,15 @@ IN: furnace:pastebin
 USING: calendar kernel namespaces sequences furnace hashtables
 math ;
 
-TUPLE: paste n summary author contents date ;
+TUPLE: paste n summary author channel contents date annotations ;
 
-C: paste ( summary author contents -- paste )
+TUPLE: annotation summary author contents ;
+
+C: paste ( summary author channel contents -- paste )
+    V{ } clone over set-paste-annotations
     [ set-paste-contents ] keep
     [ set-paste-author ] keep
+    [ set-paste-channel ] keep
     [ set-paste-summary ] keep ;
 
 TUPLE: pastebin pastes ;
@@ -19,30 +23,31 @@ C: pastebin ( -- pastebin )
     dup pastebin-pastes length pick set-paste-n
     pastebin-pastes push ;
 
-<pastebin> "pastebin" set-global
+<pastebin> pastebin set-global
 
 : get-paste ( n -- paste )
-    "pastebin" get pastebin-pastes nth ;
+    pastebin get pastebin-pastes nth ;
 
 : show-paste ( n -- )
     "Paste"
-    swap string>number get-paste
+    swap get-paste
     "show-paste" render-page ;
 
-\ show-paste { { "n" "0" } } define-action
+\ show-paste { { "n" v-number } } define-action
 
 : new-paste ( -- )
     "New paste" f "new-paste" render-page ;
 
 \ new-paste { } define-action
 
-: submit-paste ( summary author contents -- )
-    <paste> "pastebin" get-global add-paste ;
+: submit-paste ( summary author channel contents -- )
+    <paste> pastebin get-global add-paste ;
 
 \ submit-paste {
-    { "summary" "" }
-    { "author" "" }
-    { "contents" "" }
+    { "summary" v-required }
+    { "author" v-required }
+    { "channel" "#concatenative" v-default }
+    { "contents" v-required }
 } define-action
 
 : paste-list ( -- )
@@ -51,7 +56,7 @@ C: pastebin ( -- pastebin )
         [ new-paste ] "new-paste-quot" set
 
         "Pastebin"
-        "pastebin" get
+        pastebin get
         "paste-list" render-page
     ] with-scope ;
 
@@ -60,3 +65,15 @@ C: pastebin ( -- pastebin )
 \ submit-paste [ paste-list ] define-redirect
 
 "pastebin" "paste-list" "contrib/furnace-pastebin" web-app
+
+: annotate-paste ( paste# summary author contents -- )
+    <annotation> swap get-paste paste-annotations push ;
+
+\ annotate-paste {
+    { "n" v-required v-number }
+    { "summary" v-required }
+    { "author" v-required }
+    { "contents" v-required }
+} define-action
+
+\ annotate-paste [ "n" show-paste ] define-redirect

contrib/furnace-pastebin/show-paste.fhtml

@@ -1,9 +1,15 @@
-<% USING: namespaces io ; %>
+<% USING: namespaces io furnace sequences ; %>
+
+<h1>Paste: <% "summary" get write %></h1>
 
 <table>
-<tr><th>Summary:</th><td><% "summary" get write %></td></tr>
 <tr><th>Paste by:</th><td><% "author" get write %></td></tr>
+<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
 <tr><th>Created:</th><td><% "date" get write %></td></tr>
 </table>
 
 <pre><% "contents" get write %></pre>
+
+<% "annotations" get [ "annotation" render-template ] each %>
+
+<% model get "annotate-paste" render-template %>

contrib/furnace/load.factor

@@ -1,7 +1,9 @@
 REQUIRES: contrib/httpd ;
 
 PROVIDE: contrib/furnace {
+    "validator.factor"
     "responder.factor"
 } {
+    "test/validator.factor"
     "test/responder.factor"
 } ;

contrib/furnace/responder.factor

@@ -1,7 +1,9 @@
+! Copyright (C) 2006 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 IN: furnace
 USING: embedded generic arrays namespaces prettyprint io
 sequences words kernel httpd html errors hashtables http
-callback-responder ;
+callback-responder vectors strings ;
 
 SYMBOL: default-action
 
@@ -38,12 +40,14 @@ PREDICATE: word action "action" word-prop ;
         word-name %
     ] "" make swap build-url ;
 
-: action-call? ( args obj -- ? )
-    action? >r [ word? not ] all? r> and ;
+: action-call? ( quot -- ? )
+    >vector dup pop action? >r [ word? not ] all? r> and ;
+
+: unclip* dup 1 head* swap peek ;
 
 : quot-link ( quot -- url )
-    1 swap cut* peek 2dup action-call? [
-        [ quot>query ] keep action-link
+    dup action-call? [
+        unclip* [ quot>query ] keep action-link
     ] [
         t register-html-callback
     ] if ;
@@ -51,18 +55,25 @@ PREDICATE: word action "action" word-prop ;
 : render-link ( quot name -- )
     <a swap quot-link =href a> write </a> ;
 
+: action-param ( params paramspec -- obj error/f )
+    unclip rot hash swap >quotation apply-validators ;
+
 : query>quot ( params action -- seq )
-    "action-params" word-prop
-    [ dup first rot hash [ ] [ second ] ?if ] map-with ;
+    "action-params" word-prop [ action-param drop ] map-with ;
+
+SYMBOL: request-params
 
 : perform-redirect ( action -- )
-    "action-redirect" word-prop [ quot-link redirect ] when* ;
+    "action-redirect" word-prop
+    [ dup string? [ request-params get hash ] when ] map
+    [ quot-link redirect ] when* ;
 
 : call-action ( params action -- )
+    over request-params set
     [ query>quot ] keep [ add >quotation call ] keep
     perform-redirect ;
 
-: service-request ( url params -- )
+: service-request ( params url -- )
     current-action [
         [ call-action ] [ <pre> print-error </pre> ] recover
     ] [
@@ -77,9 +88,11 @@ PREDICATE: word action "action" word-prop ;
     dup tuple>array 2 tail swap class "slot-names" word-prop
     [ set ] 2each ;
 
+SYMBOL: model
+
 : call-template ( model template -- )
     [
-        >r [ explode-tuple ] when* r>
+        >r [ dup model set explode-tuple ] when* r>
         ".fhtml" append resource-path run-embedded-file
     ] with-scope ;
 

contrib/furnace/test/responder.factor

@@ -1,9 +1,26 @@
 IN: temporary
-USING: test namespaces furnace ;
+USING: test namespaces furnace math kernel sequences ;
+
+TUPLE: test-tuple m n ;
+
+[ H{ { "m" 3 } { "n" 2 } } ]
+[
+    [ T{ test-tuple f 3 2 } explode-tuple ] make-hash
+] unit-test
+
+[
+    { 3 }
+] [
+    H{ { "n" "3" } } { { "n" v-number } }
+    [ action-param drop ] map-with
+] unit-test
 
 : foo ;
 
-\ foo { { "foo" "2" } { "bar" f } } define-action
+\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action
+
+[ t ] [ [ 1 2 foo ] action-call? ] unit-test
+[ f ] [ [ 2 + ] action-call? ] unit-test
 
 [
     { "2" "hello" }
@@ -11,9 +28,7 @@ USING: test namespaces furnace ;
     [
         H{
             { "bar" "hello" }
-        } "query" set
-
-        \ foo query>quot
+        } \ foo query>quot
     ] with-scope
 ] unit-test
 

contrib/furnace/test/validator.factor

@@ -0,0 +1,30 @@
+IN: temporary
+USING: test namespaces furnace math kernel sequences ;
+
+[
+    123 f
+] [
+    H{ { "foo" "123" } } { "foo" v-number } action-param
+] unit-test
+
+: validation-fails
+    [ action-param nip not ] append [ f ] swap unit-test ;
+
+[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails
+
+[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails
+
+[ "ABCD" f ]
+[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ]
+unit-test
+
+[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ]
+validation-fails
+
+[ "AB" f ]
+[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ]
+unit-test
+
+[ "AB" f ]
+[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ]
+unit-test

contrib/furnace/validator.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2006 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: furnace
+USING: generic kernel errors words sequences math
+namespaces ;
+
+TUPLE: validation-error reason ;
+
+: apply-validators ( string quot -- obj error/f )
+    [
+        call f
+    ] [
+        dup validation-error? [ >r 2drop f r> ] [ rethrow ] if
+    ] recover ;
+
+: validation-error ( msg -- * ) <validation-error> throw ;
+
+: v-default ( obj value -- obj )
+    over empty? [ nip ] [ drop ] if ;
+
+: v-required ( str -- str )
+    dup empty? [ "required" validation-error ] when ;
+
+: v-min-length ( str n -- str )
+    over length over < [
+        [ "must be at least " % # " characters" % ] "" make
+        validation-error
+    ] [
+        drop
+    ] if ;
+
+: v-max-length ( str n -- str )
+    over length over > [
+        [ "must be no more than " % # " characters" % ] "" make
+        validation-error
+    ] [
+        drop
+    ] if ;
+
+: v-number ( str -- n )
+    string>number [
+        "must be a number" validation-error
+    ] unless* ;