New html.forms abstraction fixes some problems; clean up some code

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 ] [
         <ul "errors" =class ul>
-            [ <li> message>> escape-string write </li> ] each
+            [ <li> escape-string write </li> ] each
         </ul>
     ] if ;
 
@@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ;
 : <action> ( -- 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 } <flash-redirect>
+    ] [ <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 <flash-redirect> ] [ <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 ;

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 ;

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

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 -- )

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

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? [ <mirror> ] unless
-    values get swap update ;
-
-: deposit-values ( destination names -- )
-    [ dup value ] H{ } map>assoc update ;
-
-: deposit-slots ( destination names -- )
-    [ <mirror> ] 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* ;
 
 <PRIVATE
 

extra/html/forms/forms-tests.factor

@@ -0,0 +1,67 @@
+IN: html.forms.tests
+USING: kernel sequences tools.test assocs html.forms validators accessors
+namespaces ;
+
+: with-validation ( quot -- messages )
+    [
+        begin-form
+        call
+    ] with-scope ; inline
+
+[ 14 ] [
+    [
+        "14" [ v-number 13 v-min-value 100 v-max-value ] validate
+    ] with-validation
+] unit-test
+
+[ t ] [
+    [
+        "140" [ v-number 13 v-min-value 100 v-max-value ] validate
+        [ validation-error? ]
+        [ value>> "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

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 ;
+
+: <form> ( -- form )
+    form new
+        V{ } clone >>errors
+        H{ } clone >>values ;
+
+M: form clone
+    call-next-method
+        [ clone ] change-errors
+        [ clone ] change-values ;
+
+: check-value-name ( name -- name )
+    dup string? [ "Value name not a string" throw ] unless ;
+
+: values ( -- assoc )
+    form get values>> ;
+
+: value ( name -- value )
+    check-value-name values at ;
+
+: set-value ( value name -- )
+    check-value-name values set-at ;
+
+: begin-form ( -- ) <form> form set ;
+
+: prepare-value ( name object -- value name object )
+    [ [ value ] keep ] dip ; inline
+
+: from-object ( object -- )
+    [ values ] [ make-mirror ] bi* update ;
+
+: to-object ( destination names -- )
+    [ make-mirror ] [ values extract-keys ] bi* update ;
+
+: with-each-value ( name quot -- )
+    [ value ] dip '[
+        [
+            form [ clone ] change
+            1+ "index" set-value
+            "value" set-value
+            @
+        ] with-scope
+    ] each-index ; inline
+
+: with-each-object ( name quot -- )
+    [ value ] dip '[
+        [
+            begin-form
+            1+ "index" set-value
+            from-object
+            @
+        ] with-scope
+    ] each-index ; inline
+
+SYMBOL: nested-forms
+
+: with-form ( name quot -- )
+    '[
+        ,
+        [ nested-forms [ swap prefix ] change ]
+        [ value form set ]
+        bi
+        @
+    ] with-scope ; inline
+
+: nest-form ( name quot -- )
+    swap [
+        [
+            <form> form set
+            call
+            form get
+        ] with-scope
+    ] dip set-value ; inline
+
+TUPLE: validation-error value message ;
+
+C: <validation-error> validation-error
+
+: validation-error ( message -- )
+    form get
+    t >>validation-failed
+    errors>> push ;
+
+: validation-failed? ( -- ? )
+    form get validation-failed>> ;
+
+: define-validators ( class validators -- )
+    >hashtable "validators" set-word-prop ;
+
+: validate ( value quot -- result )
+    [ <validation-error> ] recover ; inline
+
+: validate-value ( name value quot -- )
+    validate
+    dup validation-error? [ form get t >>validation-failed drop ] when
+    swap set-value ;
+
+: validate-values ( assoc validators -- assoc' )
+    swap '[ dup , at _ validate-value ] assoc-each ;

extra/html/templates/chloe/chloe-tests.factor

@@ -9,13 +9,13 @@ IN: html.templates.chloe.tests
 [ f ] [ "" parse-query-attr ] unit-test
 
 [ H{ { "a" "b" } } ] [
-    blank-values
+    begin-form
     "b" "a" set-value
     "a" parse-query-attr
 ] unit-test
 
 [ H{ { "a" "b" } { "c" "d" } } ] [
-    blank-values
+    begin-form
     "b" "a" set-value
     "d" "c" set-value
     "a,c" parse-query-attr
@@ -69,7 +69,7 @@ IN: html.templates.chloe.tests
     ] run-template
 ] unit-test
 
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
 
 [ ] [ "A label" "label" set-value ] unit-test
 
@@ -157,7 +157,7 @@ TUPLE: person first-name last-name ;
     ] run-template
 ] unit-test
 
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
 
 [ ] [
     H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
@@ -170,7 +170,7 @@ TUPLE: person first-name last-name ;
 ] unit-test
 
 [ ] [
-    blank-values
+    begin-form
     { "a" "b" } "choices" set-value
     "true" "b" set-value
 ] unit-test

extra/html/templates/chloe/chloe.factor

@@ -5,6 +5,7 @@ classes.tuple assocs splitting words arrays memoize
 io io.files io.encodings.utf8 io.streams.string
 unicode.case tuple-syntax mirrors fry math urls present
 multiline xml xml.data xml.writer xml.utilities
+html.forms
 html.elements
 html.components
 html.templates
@@ -76,7 +77,7 @@ CHLOE: each [ with-each-value ] (bind-tag) ;
 
 CHLOE: bind-each [ with-each-object ] (bind-tag) ;
 
-CHLOE: bind [ with-values ] (bind-tag) ;
+CHLOE: bind [ with-form ] (bind-tag) ;
 
 : error-message-tag ( tag -- )
     children>string render-error ;

extra/http/http-tests.factor

@@ -223,7 +223,8 @@ test-db [
 
 [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
 
-USING: html.components html.elements xml xml.utilities validators
+USING: html.components html.elements html.forms
+xml xml.utilities validators
 furnace furnace.flash ;
 
 SYMBOL: a

extra/validators/validators-tests.factor

@@ -2,14 +2,6 @@ IN: validators.tests
 USING: kernel sequences tools.test validators accessors
 namespaces assocs ;
 
-: with-validation ( quot -- messages )
-    [
-        init-validation
-        call
-        validation-messages get
-        named-validation-messages get >alist append
-    ] with-scope ; inline
-
 [ "" v-one-line ] must-fail
 [ "hello world" ] [ "hello world" v-one-line ] unit-test
 [ "hello\nworld" v-one-line ] must-fail
@@ -60,59 +52,3 @@ namespaces assocs ;
 [ "4561_2612_1234_5467" v-credit-card ] must-fail
 
 [ "4561-2621-1234-5467" v-credit-card ] must-fail
-
-
-[ 14 V{ } ] [
-    [
-        "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
-    ] with-validation
-] unit-test
-
-[ f t ] [
-    [
-        "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
-    ] with-validation first
-    [ first "age" = ]
-    [ second validation-error? ]
-    [ second value>> "140" = ]
-    tri and and
-] unit-test
-
-TUPLE: person name age ;
-
-person {
-    { "name" [ ] }
-    { "age" [ v-number 13 v-min-value 100 v-max-value ] }
-} define-validators
-
-[ t t ] [
-    [
-        { { "age" "" } } required-values
-        validation-failed?
-    ] with-validation first
-    [ first "age" = ]
-    [ second validation-error? ]
-    [ second message>> "required" = ]
-    tri and and
-] unit-test
-
-[ H{ { "a" 123 } } f V{ } ] [
-    [
-        H{
-            { "a" "123" }
-            { "b" "c" }
-            { "c" "d" }
-        }
-        H{
-            { "a" [ v-integer ] }
-        } validate-values
-        validation-failed?
-    ] with-validation
-] unit-test
-
-[ t "foo" ] [
-    [
-        "foo" validation-error
-        validation-failed?
-    ] with-validation first message>>
-] unit-test

extra/validators/validators.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel continuations sequences sequences.lib math
-namespaces sets math.parser math.ranges assocs regexp fry
-unicode.categories arrays hashtables words combinators mirrors
+namespaces sets math.parser math.ranges assocs regexp
+unicode.categories arrays hashtables words
 classes quotations xmode.catalog ;
 IN: validators
 
@@ -107,53 +107,3 @@ IN: validators
     ] [
         "invalid credit card number format" throw
     ] if ;
-
-SYMBOL: validation-messages
-SYMBOL: named-validation-messages
-
-: init-validation ( -- )
-    V{ } clone validation-messages set
-    H{ } clone named-validation-messages set ;
-
-: (validation-message) ( obj -- )
-    validation-messages get push ;
-
-: (validation-message-for) ( obj name -- )
-    named-validation-messages get set-at ;
-
-TUPLE: validation-message message ;
-
-C: <validation-message> validation-message
-
-: validation-message ( string -- )
-    <validation-message> (validation-message) ;
-
-: validation-message-for ( string name -- )
-    [ <validation-message> ] dip (validation-message-for) ;
-
-TUPLE: validation-error message value ;
-
-C: <validation-error> validation-error
-
-: validation-error ( message -- )
-    f <validation-error> (validation-message) ;
-
-: validation-error-for ( message value name -- )
-    [ <validation-error> ] dip (validation-message-for) ;
-
-: validation-failed? ( -- ? )
-    validation-messages get [ validation-error? ] contains?
-    named-validation-messages get [ nip validation-error? ] assoc-contains?
-    or ;
-
-: define-validators ( class validators -- )
-    >hashtable "validators" set-word-prop ;
-
-: validate ( value name quot -- result )
-    '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
-
-: required-values ( assoc -- )
-    [ swap [ v-required ] validate drop ] assoc-each ;
-
-: validate-values ( assoc validators -- assoc' )
-    swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;

extra/webapps/blogs/blogs.factor

@@ -1,8 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sorting math.order math.parser
-urls validators html.components db db.types db.tuples calendar
-present http.server.dispatchers
+urls validators db db.types db.tuples calendar present
+html.forms
+html.components
+http.server.dispatchers
 furnace
 furnace.actions
 furnace.auth
@@ -142,7 +144,7 @@ M: comment entity-url
             "id" value
             "new-comment" [
                 "parent" set-value
-            ] nest-values
+            ] nest-form
         ] >>init
 
         { blogs "view-post" } >>template ;
@@ -163,7 +165,7 @@ M: comment entity-url
 
         [
             f <post>
-                dup { "title" "content" } deposit-slots
+                dup { "title" "content" } to-object
                 uid >>author
                 now >>date
             [ insert-tuple ] [ entity-url <redirect> ] bi
@@ -195,7 +197,7 @@ M: comment entity-url
 
         [
             "id" value <post>
-            dup { "title" "author" "date" "content" } deposit-slots
+            dup { "title" "author" "date" "content" } to-object
             [ update-tuple ] [ entity-url <redirect> ] bi
         ] >>submit
 

extra/webapps/pastebin/pastebin.factor

@@ -4,6 +4,7 @@ USING: namespaces assocs sorting sequences kernel accessors
 hashtables sequences.lib db.types db.tuples db combinators
 calendar calendar.format math.parser syndication urls xml.writer
 xmode.catalog validators
+html.forms
 html.components
 html.templates.chloe
 http.server
@@ -126,7 +127,7 @@ M: annotation entity-url
                 "parent" set-value
                 mode-names "modes" set-value
                 "factor" "mode" set-value
-            ] nest-values
+            ] nest-form
         ] >>init
 
         { pastebin "paste" } >>template ;
@@ -149,7 +150,7 @@ M: annotation entity-url
 
 : deposit-entity-slots ( tuple -- )
     now >>date
-    { "summary" "author" "mode" "contents" } deposit-slots ;
+    { "summary" "author" "mode" "contents" } to-object ;
 
 : <new-paste-action> ( -- action )
     <page-action>
@@ -160,11 +161,12 @@ M: annotation entity-url
 
         { pastebin "new-paste" } >>template
 
-        [ mode-names "modes" set-value ] >>validate
+        [
+            mode-names "modes" set-value
+            validate-entity
+        ] >>validate
 
         [
-            validate-entity
-
             f <paste>
             [ deposit-entity-slots ]
             [ insert-tuple ]
@@ -196,6 +198,7 @@ M: annotation entity-url
 : <new-annotation-action> ( -- action )
     <action>
         [
+            mode-names "modes" set-value
             { { "parent" [ v-integer ] } } validate-params
             validate-entity
         ] >>validate

extra/webapps/planet/planet.factor

@@ -3,9 +3,9 @@
 USING: kernel accessors sequences sorting math math.order
 calendar alarms logging concurrency.combinators namespaces
 sequences.lib db.types db.tuples db fry locals hashtables
+syndication urls xml.writer validators
+html.forms
 html.components
-syndication urls xml.writer
-validators
 http.server
 http.server.dispatchers
 furnace
@@ -130,7 +130,7 @@ posting "POSTINGS"
     } validate-params ;
 
 : deposit-blog-slots ( blog -- )
-    { "name" "www-url" "feed-url" } deposit-slots ;
+    { "name" "www-url" "feed-url" } to-object ;
 
 : <new-blog-action> ( -- action )
     <page-action>

extra/webapps/todo/todo.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences namespaces
 db db.types db.tuples validators hashtables urls
+html.forms
 html.components
 html.templates.chloe
 http.server
@@ -62,7 +63,7 @@ todo "TODO"
 
         [
             f <todo>
-                dup { "summary" "priority" "description" } deposit-slots
+                dup { "summary" "priority" "description" } to-object
             [ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
         ] >>submit ;
 
@@ -82,7 +83,7 @@ todo "TODO"
 
         [
             f <todo>
-                dup { "id" "summary" "priority" "description" } deposit-slots
+                dup { "id" "summary" "priority" "description" } to-object
             [ update-tuple ] [ id>> view-todo-url <redirect> ] bi
         ] >>submit ;
 

extra/webapps/user-admin/edit-user.xml

@@ -50,11 +50,11 @@
 	</table>
 	
 	<p>
-		<button type="submit" class="link-button link">Update</button>
+		<button type="submit" >Update</button>
 		<t:validation-messages />
 	</p>
 
 	</t:form>
 
-	<t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
+	<t:button t:action="$user-admin/delete" t:for="username">Delete</t:button>
 </t:chloe>

extra/webapps/user-admin/user-admin.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors namespaces combinators words
 assocs db.tuples arrays splitting strings validators urls
+html.forms
 html.elements
 html.components
 furnace
@@ -26,10 +27,19 @@ TUPLE: user-admin < dispatcher ;
 : init-capabilities ( -- )
     capabilities get words>strings "capabilities" set-value ;
 
-: selected-capabilities ( -- seq )
+: validate-capabilities ( -- )
     "capabilities" value
-    [ param empty? not ] filter
-    [ string>word ] map ;
+    [ [ param empty? not ] keep set-value ] each ;
+
+: selected-capabilities ( -- seq )
+    "capabilities" value [ value ] filter [ string>word ] map ;
+
+: validate-user ( -- )
+    {
+        { "username" [ v-username ] }
+        { "realname" [ [ v-one-line ] v-optional ] }
+        { "email" [ [ v-email ] v-optional ] }
+    } validate-params ;
 
 : <new-user-action> ( -- action )
     <page-action>
@@ -42,14 +52,13 @@ TUPLE: user-admin < dispatcher ;
 
         [
             init-capabilities
+            validate-capabilities
+
+            validate-user
 
             {
-                { "username" [ v-username ] }
-                { "realname" [ v-one-line ] }
                 { "new-password" [ v-password ] }
                 { "verify-password" [ v-password ] }
-                { "email" [ [ v-email ] v-optional ] }
-                { "capabilities" [ ] }
             } validate-params
 
             same-password-twice
@@ -74,14 +83,16 @@ TUPLE: user-admin < dispatcher ;
 : validate-username ( -- )
     { { "username" [ v-username ] } } validate-params ;
 
+: select-capabilities ( seq -- )
+    [ t swap word>string set-value ] each ;
+
 : <edit-user-action> ( -- action )
     <page-action>
         [
             validate-username
 
             "username" value <user> select-tuple
-            [ from-object ]
-            [ capabilities>> [ "true" swap word>string set-value ] each ] bi
+            [ from-object ] [ capabilities>> select-capabilities ] bi
 
             init-capabilities
         ] >>init
@@ -89,14 +100,17 @@ TUPLE: user-admin < dispatcher ;
         { user-admin "edit-user" } >>template
 
         [
+            "username" value <user> select-tuple
+            [ from-object ] [ capabilities>> select-capabilities ] bi
+
             init-capabilities
+            validate-capabilities
+
+            validate-user
 
             {
-                { "username" [ v-username ] }
-                { "realname" [ v-one-line ] }
                 { "new-password" [ [ v-password ] v-optional ] }
                 { "verify-password" [ [ v-password ] v-optional ] }
-                { "email" [ [ v-email ] v-optional ] }
             } validate-params
 
             "new-password" "verify-password"