diff --git a/contrib/furnace-pastebin/annotate-paste.fhtml b/contrib/furnace-pastebin/annotate-paste.fhtml
new file mode 100644
index 0000000000..24f0d4ea94
--- /dev/null
+++ b/contrib/furnace-pastebin/annotate-paste.fhtml
@@ -0,0 +1,28 @@
+<% USING: namespaces math io ; %>
+
+
Annotate
+
+
diff --git a/contrib/furnace-pastebin/annotation.fhtml b/contrib/furnace-pastebin/annotation.fhtml
new file mode 100644
index 0000000000..ed1bdac845
--- /dev/null
+++ b/contrib/furnace-pastebin/annotation.fhtml
@@ -0,0 +1,11 @@
+<% USING: namespaces io ; %>
+
+Annotation: <% "summary" get write %>
+
+
+| Annotation by: | <% "author" get write %> |
+| Channel: | <% "channel" get write %> |
+| Created: | <% "date" get write %> |
+
+
+<% "contents" get write %>
diff --git a/contrib/furnace-pastebin/new-paste.fhtml b/contrib/furnace-pastebin/new-paste.fhtml
index c9a393105c..36f0397b67 100644
--- a/contrib/furnace-pastebin/new-paste.fhtml
+++ b/contrib/furnace-pastebin/new-paste.fhtml
@@ -12,6 +12,11 @@
|
+
+| Channel: |
+ |
+
+
| Contents: |
|
diff --git a/contrib/furnace-pastebin/pastebin.factor b/contrib/furnace-pastebin/pastebin.factor
index 1bd2b64a2a..1b88911348 100644
--- a/contrib/furnace-pastebin/pastebin.factor
+++ b/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" set-global
+ 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 -- )
- "pastebin" get-global add-paste ;
+: submit-paste ( summary author channel contents -- )
+ 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 -- )
+ 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
diff --git a/contrib/furnace-pastebin/show-paste.fhtml b/contrib/furnace-pastebin/show-paste.fhtml
index 81394e3871..b3b4e99b6e 100644
--- a/contrib/furnace-pastebin/show-paste.fhtml
+++ b/contrib/furnace-pastebin/show-paste.fhtml
@@ -1,9 +1,15 @@
-<% USING: namespaces io ; %>
+<% USING: namespaces io furnace sequences ; %>
+
+Paste: <% "summary" get write %>
-| Summary: | <% "summary" get write %> |
| Paste by: | <% "author" get write %> |
+| Channel: | <% "channel" get write %> |
| Created: | <% "date" get write %> |
<% "contents" get write %>
+
+<% "annotations" get [ "annotation" render-template ] each %>
+
+<% model get "annotate-paste" render-template %>
diff --git a/contrib/furnace/load.factor b/contrib/furnace/load.factor
index 4616e604f3..8fe59c6ed0 100644
--- a/contrib/furnace/load.factor
+++ b/contrib/furnace/load.factor
@@ -1,7 +1,9 @@
REQUIRES: contrib/httpd ;
PROVIDE: contrib/furnace {
+ "validator.factor"
"responder.factor"
} {
+ "test/validator.factor"
"test/responder.factor"
} ;
diff --git a/contrib/furnace/responder.factor b/contrib/furnace/responder.factor
index 0bf43b2cbd..7599c8873b 100644
--- a/contrib/furnace/responder.factor
+++ b/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 -- )
write ;
+: 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 ] [ print-error
] 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 ;
diff --git a/contrib/furnace/test/responder.factor b/contrib/furnace/test/responder.factor
index 1ae0a4f1eb..d451be5024 100644
--- a/contrib/furnace/test/responder.factor
+++ b/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
diff --git a/contrib/furnace/test/validator.factor b/contrib/furnace/test/validator.factor
new file mode 100644
index 0000000000..e7d92c704e
--- /dev/null
+++ b/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
diff --git a/contrib/furnace/validator.factor b/contrib/furnace/validator.factor
new file mode 100644
index 0000000000..9efc944171
--- /dev/null
+++ b/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 -- * ) 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* ;