http.server.responses\r
furnace\r
furnace.flash\r
+html.forms\r
html.elements\r
html.components\r
html.components\r
SYMBOL: rest\r
\r
: render-validation-messages ( -- )\r
- validation-messages get\r
+ form get errors>>\r
dup empty? [ drop ] [\r
<ul "errors" =class ul>\r
- [ <li> message>> escape-string write </li> ] each\r
+ [ <li> escape-string write </li> ] each\r
</ul>\r
] if ;\r
\r
: <action> ( -- action )\r
action new-action ;\r
\r
-: flashed-variables ( -- seq )\r
- { validation-messages named-validation-messages } ;\r
+: set-nested-form ( form name -- )\r
+ dup empty? [\r
+ drop form set\r
+ ] [\r
+ dup length 1 = [\r
+ first set-value\r
+ ] [\r
+ unclip [ set-nested-form ] nest-form\r
+ ] if\r
+ ] if ;\r
+\r
+: restore-validation-errors ( -- )\r
+ form fget [\r
+ nested-forms fget set-nested-form\r
+ ] when* ;\r
\r
: handle-get ( action -- response )\r
'[\r
{\r
[ init>> call ]\r
[ authorize>> call ]\r
- [ drop flashed-variables restore-flash ]\r
+ [ drop restore-validation-errors ]\r
[ display>> call ]\r
} cleave\r
] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
-: validation-failed ( -- * )\r
- post-request? [ f ] [ <400> ] if exit-with ;\r
-\r
-: (handle-post) ( action -- response )\r
- '[\r
- , dup submit>> [\r
- [ validate>> call ]\r
- [ authorize>> call ]\r
- [ submit>> call ]\r
- tri\r
- ] [ drop <400> ] if\r
- ] with-exit-continuation ;\r
-\r
: param ( name -- value )\r
params get at ;\r
\r
revalidate-url-key param\r
dup [ >url [ same-host? ] keep and ] when ;\r
\r
+: validation-failed ( -- * )\r
+ post-request? revalidate-url and\r
+ [\r
+ nested-forms-key param " " split harvest nested-forms set\r
+ { form nested-forms } <flash-redirect>\r
+ ] [ <400> ] if*\r
+ exit-with ;\r
+\r
: handle-post ( action -- response )\r
'[\r
- form-nesting-key params get at " " split harvest\r
- [ , (handle-post) ]\r
- [ swap '[ , , nest-values ] ] reduce\r
- call\r
- ] with-exit-continuation\r
- [\r
- revalidate-url\r
- [ flashed-variables <flash-redirect> ] [ <403> ] if*\r
- ] unless* ;\r
+ , dup submit>> [\r
+ [ validate>> call ]\r
+ [ authorize>> call ]\r
+ [ submit>> call ]\r
+ tri\r
+ ] [ drop <400> ] if\r
+ ] with-exit-continuation ;\r
\r
: handle-rest ( path action -- assoc )\r
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
\r
: init-action ( path action -- )\r
- blank-values\r
- init-validation\r
+ begin-form\r
handle-rest\r
request get request-params assoc-union params set ;\r
\r
validation-failed? [ validation-failed ] when ;\r
\r
: validate-params ( validators -- )\r
- params get swap validate-values from-object\r
- check-validation ;\r
+ params get swap validate-values check-validation ;\r
\r
: validate-integer-id ( -- )\r
{ { "id" [ v-number ] } } validate-params ;\r
checksums\r
checksums.sha2\r
validators\r
+html.forms\r
html.components\r
html.elements\r
urls\r
IN: furnace.auth.login\r
\r
: word>string ( word -- string )\r
- [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;\r
+ [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;\r
\r
: words>strings ( seq -- seq' )\r
[ word>string ] map ;\r
\r
+ERROR: no-such-word name vocab ;\r
+\r
: string>word ( string -- word )\r
- ":" split1 swap lookup ;\r
+ ":" split1 swap 2dup lookup dup\r
+ [ 2nip ] [ drop no-such-word ] if ;\r
\r
: strings>words ( seq -- seq' )\r
[ string>word ] map ;\r
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
xml.writer
html.components
html.elements
+html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
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 -- )
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
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "new york" "city1" set-value ] unit-test
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ t "delivery" set-value ] unit-test
=
] 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
! 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
--- /dev/null
+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
--- /dev/null
+! 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 ;
[ 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
] run-template
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
] run-template
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [
H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
] unit-test
[ ] [
- blank-values
+ begin-form
{ "a" "b" } "choices" set-value
"true" "b" set-value
] unit-test
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
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 ;
[ "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
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
[ "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
! 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
] [
"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 ;
! 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
"id" value
"new-comment" [
"parent" set-value
- ] nest-values
+ ] nest-form
] >>init
{ blogs "view-post" } >>template ;
[
f <post>
- dup { "title" "content" } deposit-slots
+ dup { "title" "content" } to-object
uid >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
[
"id" value <post>
- dup { "title" "author" "date" "content" } deposit-slots
+ dup { "title" "author" "date" "content" } to-object
[ update-tuple ] [ entity-url <redirect> ] bi
] >>submit
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
"parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
- ] nest-values
+ ] nest-form
] >>init
{ pastebin "paste" } >>template ;
: deposit-entity-slots ( tuple -- )
now >>date
- { "summary" "author" "mode" "contents" } deposit-slots ;
+ { "summary" "author" "mode" "contents" } to-object ;
: <new-paste-action> ( -- action )
<page-action>
{ pastebin "new-paste" } >>template
- [ mode-names "modes" set-value ] >>validate
-
[
+ mode-names "modes" set-value
validate-entity
+ ] >>validate
+ [
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
: <new-annotation-action> ( -- action )
<action>
[
+ mode-names "modes" set-value
{ { "parent" [ v-integer ] } } validate-params
validate-entity
] >>validate
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
} 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>
! 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
[
f <todo>
- dup { "summary" "priority" "description" } deposit-slots
+ dup { "summary" "priority" "description" } to-object
[ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
[
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 ;
</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>
! 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
: 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>
[
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
: 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
{ 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"
projects / factor.git / commitdiff