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 ] [ ] 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 ; + +:
( -- 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 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 set + call + form get + ] with-scope + ] dip set-value ; inline + +TUPLE: validation-error value message ; + +C: 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 ) + [ ] 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 ; diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 433aedbc9a..87ba37ed9e 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/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 diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 936c06ae7e..32fe954178 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/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 ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index bc206f08b7..88d42d9796 100755 --- a/extra/http/http-tests.factor +++ b/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 diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor index 7d4325cbb6..bd24323f20 100644 --- a/extra/validators/validators-tests.factor +++ b/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 diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor index aeb2dc2f80..37c0216740 100644 --- a/extra/validators/validators.factor +++ b/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 ( string -- ) - (validation-message) ; - -: validation-message-for ( string name -- ) - [ ] dip (validation-message-for) ; - -TUPLE: validation-error message value ; - -C: validation-error - -: validation-error ( message -- ) - f (validation-message) ; - -: validation-error-for ( message value name -- ) - [ ] 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 ; diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index d0c651c71f..760951eec6 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/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 - dup { "title" "content" } deposit-slots + dup { "title" "content" } to-object uid >>author now >>date [ insert-tuple ] [ entity-url ] bi @@ -195,7 +197,7 @@ M: comment entity-url [ "id" value - dup { "title" "author" "date" "content" } deposit-slots + dup { "title" "author" "date" "content" } to-object [ update-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index d381adafcd..251872d1ac 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/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 ; : ( -- 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 [ deposit-entity-slots ] [ insert-tuple ] @@ -196,6 +198,7 @@ M: annotation entity-url : ( -- action ) [ + mode-names "modes" set-value { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 90b2411fc1..b472881e73 100755 --- a/extra/webapps/planet/planet.factor +++ b/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 ; : ( -- action ) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 0770765754..dba10184f4 100755 --- a/extra/webapps/todo/todo.factor +++ b/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 - dup { "summary" "priority" "description" } deposit-slots + dup { "summary" "priority" "description" } to-object [ insert-tuple ] [ id>> view-todo-url ] bi ] >>submit ; @@ -82,7 +83,7 @@ todo "TODO" [ f - dup { "id" "summary" "priority" "description" } deposit-slots + dup { "id" "summary" "priority" "description" } to-object [ update-tuple ] [ id>> view-todo-url ] bi ] >>submit ; diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml index 0c55f8ca76..252667462b 100644 --- a/extra/webapps/user-admin/edit-user.xml +++ b/extra/webapps/user-admin/edit-user.xml @@ -50,11 +50,11 @@

- +

- Delete + Delete diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 19153e1354..5859d616ee 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/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 ; : ( -- 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 ; + : ( -- action ) [ validate-username "username" value 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 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"