Remove obsolete vocabularies
Slava Pestov
parent
8327449a65
commit
73a25d8471
|
|
@ -1,20 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: splitting kernel io sequences xmode.code2html accessors
|
|
||||||
http.server.components html xml.entities ;
|
|
||||||
IN: http.server.components.code
|
|
||||||
|
|
||||||
TUPLE: code-renderer < text-renderer mode ;
|
|
||||||
|
|
||||||
: <code-renderer> ( mode -- renderer )
|
|
||||||
code-renderer new-text-renderer
|
|
||||||
swap >>mode ;
|
|
||||||
|
|
||||||
M: code-renderer render-view*
|
|
||||||
[
|
|
||||||
[ string-lines ] [ mode>> value ] bi* htmlize-lines
|
|
||||||
] with-html-stream ;
|
|
||||||
|
|
||||||
: <code> ( id mode -- component )
|
|
||||||
swap <text>
|
|
||||||
swap <code-renderer> >>renderer ;
|
|
||||||
|
|
@ -1,133 +0,0 @@
|
||||||
IN: http.server.components.tests
|
|
||||||
USING: http.server.components http.server.forms
|
|
||||||
http.server.validators namespaces tools.test kernel accessors
|
|
||||||
tuple-syntax mirrors
|
|
||||||
http http.server.actions http.server.templating.fhtml
|
|
||||||
io.streams.string io.streams.null ;
|
|
||||||
|
|
||||||
validation-failed? off
|
|
||||||
|
|
||||||
[ 3 ] [ "3" "n" <number> validate ] unit-test
|
|
||||||
|
|
||||||
[ 123 ] [
|
|
||||||
""
|
|
||||||
"n" <number>
|
|
||||||
123 >>default
|
|
||||||
validate
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ f ] [ validation-failed? get ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ "3x" "n" <number> validate validation-error? ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ validation-failed? get ] unit-test
|
|
||||||
|
|
||||||
[ "" ] [ "" "email" <email> validate ] unit-test
|
|
||||||
|
|
||||||
[ "slava@jedit.org" ] [ "slava@jedit.org" "email" <email> validate ] unit-test
|
|
||||||
|
|
||||||
[ "slava@jedit.org" ] [
|
|
||||||
"slava@jedit.org"
|
|
||||||
"email" <email>
|
|
||||||
t >>required
|
|
||||||
validate
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t ] [
|
|
||||||
"a"
|
|
||||||
"email" <email>
|
|
||||||
t >>required
|
|
||||||
validate validation-error?
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t ] [ "a" "email" <email> validate validation-error? ] unit-test
|
|
||||||
|
|
||||||
TUPLE: test-tuple text number more-text ;
|
|
||||||
|
|
||||||
: <test-tuple> test-tuple new ;
|
|
||||||
|
|
||||||
: <test-form> ( -- form )
|
|
||||||
"test" <form>
|
|
||||||
"resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template
|
|
||||||
"resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template
|
|
||||||
"text" <string>
|
|
||||||
t >>required
|
|
||||||
add-field
|
|
||||||
"number" <number>
|
|
||||||
123 >>default
|
|
||||||
t >>required
|
|
||||||
0 >>min-value
|
|
||||||
10 >>max-value
|
|
||||||
add-field
|
|
||||||
"more-text" <text>
|
|
||||||
"hi" >>default
|
|
||||||
add-field ;
|
|
||||||
|
|
||||||
[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test
|
|
||||||
|
|
||||||
[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test
|
|
||||||
|
|
||||||
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
|
|
||||||
<test-tuple> from-tuple
|
|
||||||
<test-form> set-defaults
|
|
||||||
values-tuple
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[
|
|
||||||
H{
|
|
||||||
{ "text" "fdafsa" }
|
|
||||||
{ "number" "xxx" }
|
|
||||||
{ "more-text" "" }
|
|
||||||
} params set
|
|
||||||
|
|
||||||
H{ } clone values set
|
|
||||||
|
|
||||||
[ t ] [ <test-form> (validate-form) ] unit-test
|
|
||||||
|
|
||||||
[ "fdafsa" ] [ "text" value ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ "number" value validation-error? ] unit-test
|
|
||||||
] with-scope
|
|
||||||
|
|
||||||
[
|
|
||||||
[ ] [
|
|
||||||
"n" <number>
|
|
||||||
0 >>min-value
|
|
||||||
10 >>max-value
|
|
||||||
"n" set
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ "123" ] [
|
|
||||||
"123" "n" get validate value>>
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ ] [ "i" <integer> "i" set ] unit-test
|
|
||||||
|
|
||||||
[ 3 ] [
|
|
||||||
"3" "i" get validate
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ t ] [
|
|
||||||
"3.9" "i" get validate validation-error?
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
H{ } clone values set
|
|
||||||
|
|
||||||
[ ] [ 3 "i" set-value ] unit-test
|
|
||||||
|
|
||||||
[ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test
|
|
||||||
|
|
||||||
[ ] [ [ "i" get render-edit ] with-null-stream ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "t" <text> "t" set ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "hello world" "t" set-value ] unit-test
|
|
||||||
|
|
||||||
[ ] [ [ "t" get render-edit ] with-null-stream ] unit-test
|
|
||||||
] with-scope
|
|
||||||
|
|
||||||
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "password" <password> "p" set ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "pub-date" <date> "d" set ] unit-test
|
|
||||||
|
|
@ -1,401 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: accessors namespaces kernel io math.parser assocs classes
|
|
||||||
words classes.tuple arrays sequences splitting mirrors
|
|
||||||
hashtables fry locals combinators continuations math
|
|
||||||
calendar.format html html.elements xml.entities
|
|
||||||
http.server.validators ;
|
|
||||||
IN: http.server.components
|
|
||||||
|
|
||||||
! Renderer protocol
|
|
||||||
GENERIC: render-summary* ( value renderer -- )
|
|
||||||
GENERIC: render-view* ( value renderer -- )
|
|
||||||
GENERIC: render-edit* ( value id renderer -- )
|
|
||||||
|
|
||||||
M: object render-summary* render-view* ;
|
|
||||||
|
|
||||||
TUPLE: field type ;
|
|
||||||
|
|
||||||
C: <field> field
|
|
||||||
|
|
||||||
M: field render-view*
|
|
||||||
drop escape-string write ;
|
|
||||||
|
|
||||||
M: field render-edit*
|
|
||||||
<input type>> =type =name =value input/> ;
|
|
||||||
|
|
||||||
TUPLE: hidden < field ;
|
|
||||||
|
|
||||||
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
|
|
||||||
|
|
||||||
! Component protocol
|
|
||||||
SYMBOL: components
|
|
||||||
|
|
||||||
TUPLE: component id required default renderer ;
|
|
||||||
|
|
||||||
: component ( name -- component )
|
|
||||||
dup components get at
|
|
||||||
[ ] [ "No such component: " prepend throw ] ?if ;
|
|
||||||
|
|
||||||
GENERIC: init ( component -- component )
|
|
||||||
|
|
||||||
M: component init ;
|
|
||||||
|
|
||||||
GENERIC: validate* ( value component -- result )
|
|
||||||
GENERIC: component-string ( value component -- string )
|
|
||||||
|
|
||||||
SYMBOL: values
|
|
||||||
|
|
||||||
: value values get at ;
|
|
||||||
|
|
||||||
: set-value values get set-at ;
|
|
||||||
|
|
||||||
: blank-values H{ } clone values set ;
|
|
||||||
|
|
||||||
: from-tuple <mirror> values set ;
|
|
||||||
|
|
||||||
: values-tuple values get mirror-object ;
|
|
||||||
|
|
||||||
: render-view-or-summary ( component -- value renderer )
|
|
||||||
[ id>> value ] [ component-string ] [ renderer>> ] tri ;
|
|
||||||
|
|
||||||
: render-view ( component -- )
|
|
||||||
render-view-or-summary render-view* ;
|
|
||||||
|
|
||||||
: render-summary ( component -- )
|
|
||||||
render-view-or-summary render-summary* ;
|
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
: render-edit-string ( string component -- )
|
|
||||||
[ id>> ] [ renderer>> ] bi render-edit* ;
|
|
||||||
|
|
||||||
: render-edit-error ( component -- )
|
|
||||||
[ id>> value ] keep
|
|
||||||
[ [ value>> ] dip render-edit-string ]
|
|
||||||
[ drop reason>> render-error ] 2bi ;
|
|
||||||
|
|
||||||
: value-or-default ( component -- value )
|
|
||||||
[ id>> value ] [ default>> ] bi or ;
|
|
||||||
|
|
||||||
: render-edit-value ( component -- )
|
|
||||||
[ value-or-default ]
|
|
||||||
[ component-string ]
|
|
||||||
[ render-edit-string ]
|
|
||||||
tri ;
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: render-edit ( component -- )
|
|
||||||
dup id>> value validation-error?
|
|
||||||
[ render-edit-error ] [ render-edit-value ] if ;
|
|
||||||
|
|
||||||
: validate ( value component -- result )
|
|
||||||
'[
|
|
||||||
,
|
|
||||||
over empty? [
|
|
||||||
[ default>> [ v-default ] when* ]
|
|
||||||
[ required>> [ v-required ] when ]
|
|
||||||
bi
|
|
||||||
] [ validate* ] if
|
|
||||||
] with-validator ;
|
|
||||||
|
|
||||||
: new-component ( id class renderer -- component )
|
|
||||||
swap new
|
|
||||||
swap >>renderer
|
|
||||||
swap >>id
|
|
||||||
init ; inline
|
|
||||||
|
|
||||||
! String input fields
|
|
||||||
TUPLE: string < component one-line min-length max-length ;
|
|
||||||
|
|
||||||
: new-string ( id class -- component )
|
|
||||||
"text" <field> new-component
|
|
||||||
t >>one-line ; inline
|
|
||||||
|
|
||||||
: <string> ( id -- component )
|
|
||||||
string new-string ;
|
|
||||||
|
|
||||||
M: string validate*
|
|
||||||
[ one-line>> [ v-one-line ] when ]
|
|
||||||
[ min-length>> [ v-min-length ] when* ]
|
|
||||||
[ max-length>> [ v-max-length ] when* ]
|
|
||||||
tri ;
|
|
||||||
|
|
||||||
M: string component-string
|
|
||||||
drop ;
|
|
||||||
|
|
||||||
! Username fields
|
|
||||||
TUPLE: username < string ;
|
|
||||||
|
|
||||||
M: username init
|
|
||||||
2 >>min-length
|
|
||||||
20 >>max-length ;
|
|
||||||
|
|
||||||
: <username> ( id -- component )
|
|
||||||
username new-string ;
|
|
||||||
|
|
||||||
M: username validate*
|
|
||||||
call-next-method v-one-word ;
|
|
||||||
|
|
||||||
! E-mail fields
|
|
||||||
TUPLE: email < string ;
|
|
||||||
|
|
||||||
: <email> ( id -- component )
|
|
||||||
email new-string
|
|
||||||
5 >>min-length
|
|
||||||
60 >>max-length ;
|
|
||||||
|
|
||||||
M: email validate*
|
|
||||||
call-next-method dup empty? [ v-email ] unless ;
|
|
||||||
|
|
||||||
! URL fields
|
|
||||||
TUPLE: url < string ;
|
|
||||||
|
|
||||||
: <url> ( id -- component )
|
|
||||||
url new-string
|
|
||||||
5 >>min-length
|
|
||||||
60 >>max-length ;
|
|
||||||
|
|
||||||
M: url validate*
|
|
||||||
call-next-method dup empty? [ v-url ] unless ;
|
|
||||||
|
|
||||||
! Don't send passwords back to the user
|
|
||||||
TUPLE: password-renderer < field ;
|
|
||||||
|
|
||||||
: password-renderer T{ password-renderer f "password" } ;
|
|
||||||
|
|
||||||
: blank-password >r >r drop "" r> r> ;
|
|
||||||
|
|
||||||
M: password-renderer render-edit*
|
|
||||||
blank-password call-next-method ;
|
|
||||||
|
|
||||||
! Password fields
|
|
||||||
TUPLE: password < string ;
|
|
||||||
|
|
||||||
M: password init
|
|
||||||
6 >>min-length
|
|
||||||
60 >>max-length ;
|
|
||||||
|
|
||||||
: <password> ( id -- component )
|
|
||||||
password new-string
|
|
||||||
password-renderer >>renderer ;
|
|
||||||
|
|
||||||
M: password validate*
|
|
||||||
call-next-method v-one-word ;
|
|
||||||
|
|
||||||
! Number fields
|
|
||||||
TUPLE: number < string min-value max-value ;
|
|
||||||
|
|
||||||
: <number> ( id -- component )
|
|
||||||
number new-string ;
|
|
||||||
|
|
||||||
M: number validate*
|
|
||||||
[ v-number ] [
|
|
||||||
[ min-value>> [ v-min-value ] when* ]
|
|
||||||
[ max-value>> [ v-max-value ] when* ]
|
|
||||||
bi
|
|
||||||
] bi* ;
|
|
||||||
|
|
||||||
M: number component-string
|
|
||||||
drop dup [ number>string ] when ;
|
|
||||||
|
|
||||||
! Integer fields
|
|
||||||
TUPLE: integer < number ;
|
|
||||||
|
|
||||||
: <integer> ( id -- component )
|
|
||||||
integer new-string ;
|
|
||||||
|
|
||||||
M: integer validate*
|
|
||||||
call-next-method v-integer ;
|
|
||||||
|
|
||||||
! Simple captchas
|
|
||||||
TUPLE: captcha < string ;
|
|
||||||
|
|
||||||
: <captcha> ( id -- component )
|
|
||||||
captcha new-string ;
|
|
||||||
|
|
||||||
M: captcha validate*
|
|
||||||
drop v-captcha ;
|
|
||||||
|
|
||||||
! Text areas
|
|
||||||
TUPLE: text-renderer rows cols ;
|
|
||||||
|
|
||||||
: new-text-renderer ( class -- renderer )
|
|
||||||
new
|
|
||||||
60 >>cols
|
|
||||||
20 >>rows ;
|
|
||||||
|
|
||||||
: <text-renderer> ( -- renderer )
|
|
||||||
text-renderer new-text-renderer ;
|
|
||||||
|
|
||||||
M: text-renderer render-view*
|
|
||||||
drop escape-string write ;
|
|
||||||
|
|
||||||
M: text-renderer render-edit*
|
|
||||||
<textarea
|
|
||||||
[ rows>> [ number>string =rows ] when* ]
|
|
||||||
[ cols>> [ number>string =cols ] when* ] bi
|
|
||||||
[ =id ]
|
|
||||||
[ =name ] bi
|
|
||||||
textarea>
|
|
||||||
escape-string write
|
|
||||||
</textarea> ;
|
|
||||||
|
|
||||||
TUPLE: text < string ;
|
|
||||||
|
|
||||||
: new-text ( id class -- component )
|
|
||||||
new-string
|
|
||||||
f >>one-line
|
|
||||||
<text-renderer> >>renderer ;
|
|
||||||
|
|
||||||
: <text> ( id -- component )
|
|
||||||
text new-text ;
|
|
||||||
|
|
||||||
! HTML text component
|
|
||||||
TUPLE: html-text-renderer < text-renderer ;
|
|
||||||
|
|
||||||
: <html-text-renderer> ( -- renderer )
|
|
||||||
html-text-renderer new-text-renderer ;
|
|
||||||
|
|
||||||
M: html-text-renderer render-view*
|
|
||||||
drop escape-string write ;
|
|
||||||
|
|
||||||
TUPLE: html-text < text ;
|
|
||||||
|
|
||||||
: <html-text> ( id -- component )
|
|
||||||
html-text new-text
|
|
||||||
<html-text-renderer> >>renderer ;
|
|
||||||
|
|
||||||
! Date component
|
|
||||||
TUPLE: date < string ;
|
|
||||||
|
|
||||||
: <date> ( id -- component )
|
|
||||||
date new-string ;
|
|
||||||
|
|
||||||
M: date component-string
|
|
||||||
drop timestamp>string ;
|
|
||||||
|
|
||||||
! Link components
|
|
||||||
|
|
||||||
GENERIC: link-title ( obj -- string )
|
|
||||||
GENERIC: link-href ( obj -- url )
|
|
||||||
|
|
||||||
SINGLETON: link-renderer
|
|
||||||
|
|
||||||
M: link-renderer render-view*
|
|
||||||
drop <a dup link-href =href a> link-title escape-string write </a> ;
|
|
||||||
|
|
||||||
TUPLE: link < string ;
|
|
||||||
|
|
||||||
: <link> ( id -- component )
|
|
||||||
link new-string
|
|
||||||
link-renderer >>renderer ;
|
|
||||||
|
|
||||||
! List components
|
|
||||||
SYMBOL: +plain+
|
|
||||||
SYMBOL: +ordered+
|
|
||||||
SYMBOL: +unordered+
|
|
||||||
|
|
||||||
TUPLE: list-renderer component type ;
|
|
||||||
|
|
||||||
C: <list-renderer> list-renderer
|
|
||||||
|
|
||||||
: render-plain-list ( seq component quot -- )
|
|
||||||
'[ , component>> renderer>> @ ] each ; inline
|
|
||||||
|
|
||||||
: render-li-list ( seq component quot -- )
|
|
||||||
'[ <li> @ </li> ] render-plain-list ; inline
|
|
||||||
|
|
||||||
: render-ordered-list ( seq quot component -- )
|
|
||||||
<ol> render-li-list </ol> ; inline
|
|
||||||
|
|
||||||
: render-unordered-list ( seq quot component -- )
|
|
||||||
<ul> render-li-list </ul> ; inline
|
|
||||||
|
|
||||||
: render-list ( value renderer quot -- )
|
|
||||||
over type>> {
|
|
||||||
{ +plain+ [ render-plain-list ] }
|
|
||||||
{ +ordered+ [ render-ordered-list ] }
|
|
||||||
{ +unordered+ [ render-unordered-list ] }
|
|
||||||
} case ; inline
|
|
||||||
|
|
||||||
M: list-renderer render-view*
|
|
||||||
[ render-view* ] render-list ;
|
|
||||||
|
|
||||||
M: list-renderer render-summary*
|
|
||||||
[ render-summary* ] render-list ;
|
|
||||||
|
|
||||||
TUPLE: list < component ;
|
|
||||||
|
|
||||||
: <list> ( id component type -- list )
|
|
||||||
<list-renderer> list swap new-component ;
|
|
||||||
|
|
||||||
M: list component-string drop ;
|
|
||||||
|
|
||||||
! Choice
|
|
||||||
TUPLE: choice-renderer choices ;
|
|
||||||
|
|
||||||
C: <choice-renderer> choice-renderer
|
|
||||||
|
|
||||||
M: choice-renderer render-view*
|
|
||||||
drop escape-string write ;
|
|
||||||
|
|
||||||
: render-option ( text selected? -- )
|
|
||||||
<option [ "true" =selected ] when option>
|
|
||||||
escape-string write
|
|
||||||
</option> ;
|
|
||||||
|
|
||||||
: render-options ( options selected -- )
|
|
||||||
'[ dup , member? render-option ] each ;
|
|
||||||
|
|
||||||
M: choice-renderer render-edit*
|
|
||||||
<select swap =name select>
|
|
||||||
choices>> swap 1array render-options
|
|
||||||
</select> ;
|
|
||||||
|
|
||||||
TUPLE: choice < string ;
|
|
||||||
|
|
||||||
: <choice> ( id choices -- component )
|
|
||||||
swap choice new-string
|
|
||||||
swap <choice-renderer> >>renderer ;
|
|
||||||
|
|
||||||
! Menu
|
|
||||||
TUPLE: menu-renderer choices size ;
|
|
||||||
|
|
||||||
: <menu-renderer> ( choices -- renderer )
|
|
||||||
5 menu-renderer boa ;
|
|
||||||
|
|
||||||
M:: menu-renderer render-edit* ( value id renderer -- )
|
|
||||||
<select
|
|
||||||
renderer size>> [ number>string =size ] when*
|
|
||||||
id =name
|
|
||||||
"true" =multiple
|
|
||||||
select>
|
|
||||||
renderer choices>> value render-options
|
|
||||||
</select> ;
|
|
||||||
|
|
||||||
TUPLE: menu < string ;
|
|
||||||
|
|
||||||
: <menu> ( id choices -- component )
|
|
||||||
swap menu new-string
|
|
||||||
swap <menu-renderer> >>renderer ;
|
|
||||||
|
|
||||||
! Checkboxes
|
|
||||||
TUPLE: checkbox-renderer label ;
|
|
||||||
|
|
||||||
C: <checkbox-renderer> checkbox-renderer
|
|
||||||
|
|
||||||
M: checkbox-renderer render-edit*
|
|
||||||
<input
|
|
||||||
"checkbox" =type
|
|
||||||
swap =id
|
|
||||||
swap [ "true" =selected ] when
|
|
||||||
input>
|
|
||||||
label>> escape-string write
|
|
||||||
</input> ;
|
|
||||||
|
|
||||||
TUPLE: checkbox < string ;
|
|
||||||
|
|
||||||
: <checkbox> ( id label -- component )
|
|
||||||
checkbox swap <checkbox-renderer> new-component ;
|
|
||||||
|
|
@ -1,17 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: splitting kernel io sequences farkup accessors
|
|
||||||
http.server.components xml.entities ;
|
|
||||||
IN: http.server.components.farkup
|
|
||||||
|
|
||||||
TUPLE: farkup-renderer < text-renderer ;
|
|
||||||
|
|
||||||
: <farkup-renderer> ( -- renderer )
|
|
||||||
farkup-renderer new-text-renderer ;
|
|
||||||
|
|
||||||
M: farkup-renderer render-view*
|
|
||||||
drop string-lines "\n" join convert-farkup write ;
|
|
||||||
|
|
||||||
: <farkup> ( id -- component )
|
|
||||||
<text>
|
|
||||||
<farkup-renderer> >>renderer ;
|
|
||||||
|
|
@ -1,17 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: splitting kernel io sequences inspector accessors
|
|
||||||
http.server.components xml.entities html ;
|
|
||||||
IN: http.server.components.inspector
|
|
||||||
|
|
||||||
SINGLETON: inspector-renderer
|
|
||||||
|
|
||||||
M: inspector-renderer render-view*
|
|
||||||
drop [ describe ] with-html-stream ;
|
|
||||||
|
|
||||||
TUPLE: inspector < component ;
|
|
||||||
|
|
||||||
M: inspector component-string drop ;
|
|
||||||
|
|
||||||
: <inspector> ( id -- component )
|
|
||||||
inspector inspector-renderer new-component ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
|
|
||||||
|
|
@ -1,79 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel accessors assocs namespaces io.files sequences fry
|
|
||||||
http.server
|
|
||||||
http.server.actions
|
|
||||||
http.server.components
|
|
||||||
http.server.validators
|
|
||||||
http.server.templating ;
|
|
||||||
IN: http.server.forms
|
|
||||||
|
|
||||||
TUPLE: form < component
|
|
||||||
view-template edit-template summary-template
|
|
||||||
components ;
|
|
||||||
|
|
||||||
M: form init V{ } clone >>components ;
|
|
||||||
|
|
||||||
: <form> ( id -- form )
|
|
||||||
form f new-component
|
|
||||||
dup >>renderer ;
|
|
||||||
|
|
||||||
: add-field ( form component -- form )
|
|
||||||
dup id>> pick components>> set-at ;
|
|
||||||
|
|
||||||
: set-components ( form -- )
|
|
||||||
components>> components set ;
|
|
||||||
|
|
||||||
: with-form ( form quot -- )
|
|
||||||
[ [ set-components ] [ call ] bi* ] with-scope ; inline
|
|
||||||
|
|
||||||
: set-defaults ( form -- )
|
|
||||||
[
|
|
||||||
components get [
|
|
||||||
swap values get [
|
|
||||||
swap default>> or
|
|
||||||
] change-at
|
|
||||||
] assoc-each
|
|
||||||
] with-form ;
|
|
||||||
|
|
||||||
: <form-response> ( form template -- response )
|
|
||||||
[ components>> components set ] [ <html-content> ] bi* ;
|
|
||||||
|
|
||||||
: view-form ( form -- response )
|
|
||||||
dup view-template>> <form-response> ;
|
|
||||||
|
|
||||||
: edit-form ( form -- response )
|
|
||||||
dup edit-template>> <form-response> ;
|
|
||||||
|
|
||||||
: validate-param ( id component -- )
|
|
||||||
[ [ params get at ] [ validate ] bi* ]
|
|
||||||
[ drop set-value ] 2bi ;
|
|
||||||
|
|
||||||
: (validate-form) ( form -- error? )
|
|
||||||
[
|
|
||||||
validation-failed? off
|
|
||||||
components get [ validate-param ] assoc-each
|
|
||||||
validation-failed? get
|
|
||||||
] with-form ;
|
|
||||||
|
|
||||||
: validate-form ( form -- )
|
|
||||||
(validate-form) [ validation-failed ] when ;
|
|
||||||
|
|
||||||
: render-form ( value form template -- )
|
|
||||||
[
|
|
||||||
[ from-tuple ]
|
|
||||||
[ set-components ]
|
|
||||||
[ call-template ]
|
|
||||||
tri*
|
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
M: form component-string drop ;
|
|
||||||
|
|
||||||
M: form render-summary*
|
|
||||||
dup summary-template>> render-form ;
|
|
||||||
|
|
||||||
M: form render-view*
|
|
||||||
dup view-template>> render-form ;
|
|
||||||
|
|
||||||
M: form render-edit*
|
|
||||||
nip dup edit-template>> render-form ;
|
|
||||||
|
|
@ -1,29 +0,0 @@
|
||||||
IN: http.server.validators.tests
|
|
||||||
USING: kernel sequences tools.test http.server.validators
|
|
||||||
accessors ;
|
|
||||||
|
|
||||||
[ "foo" v-number ] must-fail
|
|
||||||
[ 123 ] [ "123" v-number ] unit-test
|
|
||||||
|
|
||||||
[ "slava@factorcode.org" ] [
|
|
||||||
"slava@factorcode.org" v-email
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ "slava+foo@factorcode.org" ] [
|
|
||||||
"slava+foo@factorcode.org" v-email
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ "slava@factorcode.o" v-email ]
|
|
||||||
[ "invalid e-mail" = ] must-fail-with
|
|
||||||
|
|
||||||
[ "sla@@factorcode.o" v-email ]
|
|
||||||
[ "invalid e-mail" = ] must-fail-with
|
|
||||||
|
|
||||||
[ "slava@factorcodeorg" v-email ]
|
|
||||||
[ "invalid e-mail" = ] must-fail-with
|
|
||||||
|
|
||||||
[ "http://www.factorcode.org" ]
|
|
||||||
[ "http://www.factorcode.org" v-url ] unit-test
|
|
||||||
|
|
||||||
[ "http:/www.factorcode.org" v-url ]
|
|
||||||
[ "invalid URL" = ] must-fail-with
|
|
||||||
|
|
@ -1,85 +0,0 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel continuations sequences math namespaces sets
|
|
||||||
math.parser assocs regexp fry unicode.categories sequences ;
|
|
||||||
IN: http.server.validators
|
|
||||||
|
|
||||||
SYMBOL: validation-failed?
|
|
||||||
|
|
||||||
TUPLE: validation-error value reason ;
|
|
||||||
|
|
||||||
C: <validation-error> validation-error
|
|
||||||
|
|
||||||
: with-validator ( value quot -- result )
|
|
||||||
[ validation-failed? on <validation-error> ] recover ; inline
|
|
||||||
|
|
||||||
: v-default ( str def -- str )
|
|
||||||
over empty? spin ? ;
|
|
||||||
|
|
||||||
: v-required ( str -- str )
|
|
||||||
dup empty? [ "required" throw ] when ;
|
|
||||||
|
|
||||||
: v-optional ( str quot -- str )
|
|
||||||
over empty? [ 2drop f ] [ call ] if ; inline
|
|
||||||
|
|
||||||
: v-min-length ( str n -- str )
|
|
||||||
over length over < [
|
|
||||||
[ "must be at least " % # " characters" % ] "" make
|
|
||||||
throw
|
|
||||||
] [
|
|
||||||
drop
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: v-max-length ( str n -- str )
|
|
||||||
over length over > [
|
|
||||||
[ "must be no more than " % # " characters" % ] "" make
|
|
||||||
throw
|
|
||||||
] [
|
|
||||||
drop
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: v-number ( str -- n )
|
|
||||||
dup string>number [ ] [ "must be a number" throw ] ?if ;
|
|
||||||
|
|
||||||
: v-integer ( n -- n )
|
|
||||||
dup integer? [ "must be an integer" throw ] unless ;
|
|
||||||
|
|
||||||
: v-min-value ( x n -- x )
|
|
||||||
2dup < [
|
|
||||||
[ "must be at least " % # ] "" make throw
|
|
||||||
] [
|
|
||||||
drop
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: v-max-value ( x n -- x )
|
|
||||||
2dup > [
|
|
||||||
[ "must be no more than " % # ] "" make throw
|
|
||||||
] [
|
|
||||||
drop
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: v-regexp ( str what regexp -- str )
|
|
||||||
>r over r> matches?
|
|
||||||
[ drop ] [ "invalid " prepend throw ] if ;
|
|
||||||
|
|
||||||
: v-email ( str -- str )
|
|
||||||
#! From http://www.regular-expressions.info/email.html
|
|
||||||
"e-mail"
|
|
||||||
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
|
|
||||||
v-regexp ;
|
|
||||||
|
|
||||||
: v-url ( str -- str )
|
|
||||||
"URL"
|
|
||||||
R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
|
|
||||||
v-regexp ;
|
|
||||||
|
|
||||||
: v-captcha ( str -- str )
|
|
||||||
dup empty? [ "must remain blank" throw ] unless ;
|
|
||||||
|
|
||||||
: v-one-line ( str -- str )
|
|
||||||
dup "\r\n" intersect empty?
|
|
||||||
[ "must be a single line" throw ] unless ;
|
|
||||||
|
|
||||||
: v-one-word ( str -- str )
|
|
||||||
dup [ alpha? ] all?
|
|
||||||
[ "must be a single word" throw ] unless ;
|
|
||||||
Loading…
Reference in New Issue