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