diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor
index 9cc1880cc3..4b431c83bc 100755
--- a/extra/furnace/actions/actions.factor
+++ b/extra/furnace/actions/actions.factor
@@ -8,6 +8,7 @@ http.server
http.server.responses
furnace
furnace.flash
+html.forms
html.elements
html.components
html.components
@@ -20,10 +21,10 @@ SYMBOL: params
SYMBOL: rest
: render-validation-messages ( -- )
- validation-messages get
+ form get errors>>
dup empty? [ drop ] [
- [ - message>> escape-string write
] each
+ [ - escape-string write
] each
] if ;
@@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ;
: ( -- action )
action new-action ;
-: flashed-variables ( -- seq )
- { validation-messages named-validation-messages } ;
+: set-nested-form ( form name -- )
+ dup empty? [
+ drop form set
+ ] [
+ dup length 1 = [
+ first set-value
+ ] [
+ unclip [ set-nested-form ] nest-form
+ ] if
+ ] if ;
+
+: restore-validation-errors ( -- )
+ form fget [
+ nested-forms fget set-nested-form
+ ] when* ;
: handle-get ( action -- response )
'[
@@ -46,25 +60,12 @@ TUPLE: action rest authorize init display validate submit ;
{
[ init>> call ]
[ authorize>> call ]
- [ drop flashed-variables restore-flash ]
+ [ drop restore-validation-errors ]
[ display>> call ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
-: validation-failed ( -- * )
- post-request? [ f ] [ <400> ] if exit-with ;
-
-: (handle-post) ( action -- response )
- '[
- , dup submit>> [
- [ validate>> call ]
- [ authorize>> call ]
- [ submit>> call ]
- tri
- ] [ drop <400> ] if
- ] with-exit-continuation ;
-
: param ( name -- value )
params get at ;
@@ -74,24 +75,29 @@ TUPLE: action rest authorize init display validate submit ;
revalidate-url-key param
dup [ >url [ same-host? ] keep and ] when ;
+: validation-failed ( -- * )
+ post-request? revalidate-url and
+ [
+ nested-forms-key param " " split harvest nested-forms set
+ { form nested-forms }
+ ] [ <400> ] if*
+ exit-with ;
+
: handle-post ( action -- response )
'[
- form-nesting-key params get at " " split harvest
- [ , (handle-post) ]
- [ swap '[ , , nest-values ] ] reduce
- call
- ] with-exit-continuation
- [
- revalidate-url
- [ flashed-variables ] [ <403> ] if*
- ] unless* ;
+ , dup submit>> [
+ [ validate>> call ]
+ [ authorize>> call ]
+ [ submit>> call ]
+ tri
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
: handle-rest ( path action -- assoc )
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
: init-action ( path action -- )
- blank-values
- init-validation
+ begin-form
handle-rest
request get request-params assoc-union params set ;
@@ -110,8 +116,7 @@ M: action modify-form
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
- params get swap validate-values from-object
- check-validation ;
+ params get swap validate-values check-validation ;
: validate-integer-id ( -- )
{ { "id" [ v-number ] } } validate-params ;
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index a1d2bf47c3..80005c452a 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -13,6 +13,7 @@ destructors
checksums
checksums.sha2
validators
+html.forms
html.components
html.elements
urls
@@ -34,13 +35,16 @@ QUALIFIED: smtp
IN: furnace.auth.login
: word>string ( word -- string )
- [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
+ [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
: words>strings ( seq -- seq' )
[ word>string ] map ;
+ERROR: no-such-word name vocab ;
+
: string>word ( string -- word )
- ":" split1 swap lookup ;
+ ":" split1 swap 2dup lookup dup
+ [ 2nip ] [ drop no-such-word ] if ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor
index 43e0d293a5..e06cdac090 100644
--- a/extra/furnace/flash/flash.factor
+++ b/extra/furnace/flash/flash.factor
@@ -25,7 +25,9 @@ TUPLE: flash-scopes < server-state-manager ;
SYMBOL: flash-scope
-: fget ( key -- value ) flash-scope get at ;
+: fget ( key -- value )
+ flash-scope get dup
+ [ namespace>> at ] [ 2drop f ] if ;
: get-flash-scope ( id -- flash-scope )
dup [ flash-scope get-state ] when
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index a51841d4ad..e9d1b29da8 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -10,6 +10,7 @@ xml.entities
xml.writer
html.components
html.elements
+html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
@@ -154,11 +155,11 @@ CHLOE: a
input/>
] [ 2drop ] if ;
-: form-nesting-key "__n" ;
+: nested-forms-key "__n" ;
: form-magic ( tag -- )
[ modify-form ] each-responder
- nested-values get " " join f like form-nesting-key hidden-form-field
+ nested-forms get " " join f like nested-forms-key hidden-form-field
"for" optional-attr [ "," split [ hidden render ] each ] when* ;
: form-start-tag ( tag -- )
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
index 8ec3a58611..5779371078 100644
--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@@ -1,9 +1,9 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
-html.elements html.components namespaces ;
+html.elements html.components html.forms namespaces ;
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
@@ -63,7 +63,7 @@ TUPLE: color red green blue ;
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "new york" "city1" set-value ] unit-test
@@ -101,7 +101,7 @@ TUPLE: color red green blue ;
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ t "delivery" set-value ] unit-test
@@ -167,12 +167,19 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
=
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [
"factor" [
"concatenative" "model" set-value
- ] nest-values
+ ] nest-form
] unit-test
-[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
+[
+ H{
+ {
+ "factor"
+ T{ form f V{ } H{ { "model" "concatenative" } } }
+ }
+ }
+] [ values ] unit-test
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index 7355cd153d..b6b7f22b1d 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -1,85 +1,26 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
-classes.tuple words arrays sequences sequences.lib splitting
-mirrors hashtables combinators continuations math strings
-fry locals calendar calendar.format xml.entities validators
-html.elements html.streams xmode.code2html farkup inspector
-lcs.diff2html urls present ;
+classes.tuple words arrays sequences splitting mirrors
+hashtables combinators continuations math strings inspector
+fry locals calendar calendar.format xml.entities
+validators urls present
+xmode.code2html lcs.diff2html farkup
+html.elements html.streams html.forms ;
IN: html.components
-SYMBOL: values
-
-: check-value-name ( name -- name )
- dup string? [ "Value name not a string" throw ] unless ;
-
-: value ( name -- value ) check-value-name values get at ;
-
-: set-value ( value name -- ) check-value-name values get set-at ;
-
-: blank-values ( -- ) H{ } clone values set ;
-
-: prepare-value ( name object -- value name object )
- [ [ value ] keep ] dip ; inline
-
-: from-object ( object -- )
- dup assoc? [ ] unless
- values get swap update ;
-
-: deposit-values ( destination names -- )
- [ dup value ] H{ } map>assoc update ;
-
-: deposit-slots ( destination names -- )
- [ ] dip deposit-values ;
-
-: with-each-value ( name quot -- )
- [ value ] dip '[
- [
- values [ clone ] change
- 1+ "index" set-value
- "value" set-value
- @
- ] with-scope
- ] each-index ; inline
-
-: with-each-object ( name quot -- )
- [ value ] dip '[
- [
- blank-values
- 1+ "index" set-value
- from-object
- @
- ] with-scope
- ] each-index ; inline
-
-SYMBOL: nested-values
-
-: with-values ( name quot -- )
- '[
- ,
- [ nested-values [ swap prefix ] change ]
- [ value blank-values from-object ]
- bi
- @
- ] with-scope ; inline
-
-: nest-values ( name quot -- )
- swap [
- [
- H{ } clone [ values set call ] keep
- ] with-scope
- ] dip set-value ; inline
-
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
- over named-validation-messages get at [
- [ value>> ] [ message>> ] bi
- [ -rot render* ] dip
- render-error
- ] [
- prepare-value render*
- ] if* ;
+ prepare-value
+ [
+ dup validation-error?
+ [ [ message>> ] [ value>> ] bi ]
+ [ f swap ]
+ if
+ ] 2dip
+ render*
+ [ render-error ] when* ;
> "140" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+TUPLE: person name age ;
+
+person {
+ { "name" [ ] }
+ { "age" [ v-number 13 v-min-value 100 v-max-value ] }
+} define-validators
+
+[ t t ] [
+ [
+ { { "age" "" } }
+ { { "age" [ v-required ] } }
+ validate-values
+ validation-failed?
+ "age" value
+ [ validation-error? ]
+ [ message>> "required" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+[ H{ { "a" 123 } } f ] [
+ [
+ H{
+ { "a" "123" }
+ { "b" "c" }
+ { "c" "d" }
+ }
+ H{
+ { "a" [ v-integer ] }
+ } validate-values
+ values
+ validation-failed?
+ ] with-validation
+] unit-test
+
+[ t "foo" ] [
+ [
+ "foo" validation-error
+ validation-failed?
+ form get errors>> first
+ ] with-validation
+] unit-test
diff --git a/extra/html/forms/forms.factor b/extra/html/forms/forms.factor
new file mode 100644
index 0000000000..0da3fcb0b3
--- /dev/null
+++ b/extra/html/forms/forms.factor
@@ -0,0 +1,106 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors strings namespaces assocs hashtables
+mirrors math fry sequences sequences.lib words continuations ;
+IN: html.forms
+
+TUPLE: form errors values validation-failed ;
+
+: