http.server form validation

db4
Slava Pestov 2008-03-05 21:38:15 -06:00
parent b6b8ab32b5
commit 2feda7c5d7
30 changed files with 280 additions and 442 deletions

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax libc kernel ;
USING: help.markup help.syntax libc kernel continuations ;
IN: destructors
HELP: free-always
@ -23,7 +23,7 @@ HELP: close-later
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
{ $code "[ 10 malloc free-always ] with-destructors" }

View File

@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ;
C: <dummy-destructor> dummy-destructor
M: dummy-destructor destruct ( obj -- )
M: dummy-destructor dispose ( obj -- )
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
: destroy-always

View File

@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces
sequences system vectors ;
IN: destructors
GENERIC: destruct ( obj -- )
SYMBOL: error-destructors
SYMBOL: always-destructors
TUPLE: destructor object destroyed? ;
M: destructor destruct
M: destructor dispose
dup destructor-destroyed? [
drop
] [
dup destructor-object destruct
dup destructor-object dispose
t swap set-destructor-destroyed?
] if ;
@ -29,10 +27,10 @@ M: destructor destruct
<destructor> always-destructors get push ;
: do-always-destructors ( -- )
always-destructors get [ destruct ] each ;
always-destructors get [ dispose ] each ;
: do-error-destructors ( -- )
error-destructors get [ destruct ] each ;
error-destructors get [ dispose ] each ;
: with-destructors ( quot -- )
[
@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ;
C: <memory-destructor> memory-destructor
M: memory-destructor destruct ( obj -- )
M: memory-destructor dispose ( obj -- )
memory-destructor-alien free ;
: free-always ( alien -- )
@ -63,7 +61,7 @@ C: <handle-destructor> handle-destructor
HOOK: destruct-handle io-backend ( obj -- )
M: handle-destructor destruct ( obj -- )
M: handle-destructor dispose ( obj -- )
handle-destructor-alien destruct-handle ;
: close-always ( handle -- )
@ -79,7 +77,7 @@ C: <socket-destructor> socket-destructor
HOOK: destruct-socket io-backend ( obj -- )
M: socket-destructor destruct ( obj -- )
M: socket-destructor dispose ( obj -- )
socket-destructor-alien destruct-socket ;
: close-socket-always ( handle -- )

View File

@ -1,2 +0,0 @@
Slava Pestov
Doug Coleman

View File

@ -1,47 +0,0 @@
USING: kernel sequences namespaces math tools.test furnace furnace.validator ;
IN: furnace.tests
TUPLE: test-tuple m n ;
[ H{ { "m" 3 } { "n" 2 } } ]
[
[ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc
] unit-test
[
{ 3 }
] [
H{ { "n" "3" } } { { "n" v-number } }
[ action-param drop ] with map
] unit-test
: foo ;
\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action
[ t ] [ [ 1 2 foo ] action-call? ] unit-test
[ f ] [ [ 2 + ] action-call? ] unit-test
[
{ "2" "hello" }
] [
[
H{
{ "bar" "hello" }
} \ foo query>seq
] with-scope
] unit-test
[
H{ { "foo" "1" } { "bar" "2" } }
] [
{ "1" "2" } \ foo quot>query
] unit-test
[
"/responder/furnace.tests/foo?foo=3"
] [
[
[ "3" foo ] quot-link
] with-scope
] unit-test

View File

@ -1,217 +0,0 @@
! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs calendar debugger furnace.sessions
furnace.validator hashtables heaps html.elements http
http.server.responders http.server.templating io.files kernel
math namespaces quotations sequences splitting words strings
vectors webapps.callback continuations tuples classes vocabs
html io ;
IN: furnace
: code>quotation ( word/quot -- quot )
dup word? [ 1quotation ] when ;
SYMBOL: default-action
SYMBOL: template-path
: render-template ( template -- )
template-path get swap path+
".furnace" append resource-path
run-template-file ;
: define-action ( word hash -- )
over t "action" set-word-prop
"action-params" set-word-prop ;
: define-form ( word1 word2 hash -- )
dupd define-action
swap code>quotation "form-failed" set-word-prop ;
: default-values ( word hash -- )
"default-values" set-word-prop ;
SYMBOL: request-params
SYMBOL: current-action
SYMBOL: validators-errored
SYMBOL: validation-errors
: build-url ( str query-params -- newstr )
[
over %
dup assoc-empty? [
2drop
] [
CHAR: ? rot member? "&" "?" ? %
assoc>query %
] if
] "" make ;
: action-link ( query action -- url )
[
"/responder/" %
dup word-vocabulary "webapps." ?head drop %
"/" %
word-name %
] "" make swap build-url ;
: action-param ( hash paramsepc -- obj error/f )
unclip rot at swap >quotation apply-validators ;
: query>seq ( hash word -- seq )
"action-params" word-prop [
dup first -rot
action-param [
t validators-errored >session
rot validation-errors session> set-at
] [
nip
] if*
] with map ;
: lookup-session ( hash -- session )
"furnace-session-id" over at get-session
[ ] [ new-session "furnace-session-id" roll set-at ] ?if ;
: quot>query ( seq action -- hash )
>r >array r> "action-params" word-prop
[ first swap 2array ] 2map >hashtable ;
PREDICATE: word action "action" word-prop ;
: action-call? ( quot -- ? )
>vector dup pop action? >r [ word? not ] all? r> and ;
: unclip* dup 1 head* swap peek ;
: quot-link ( quot -- url )
dup action-call? [
unclip* [ quot>query ] keep action-link
] [
t register-html-callback
] if ;
: replace-variables ( quot -- quot )
[ dup string? [ request-params session> at ] when ] map ;
: furnace-session-id ( -- hash )
"furnace-session-id" request-params session> at
"furnace-session-id" associate ;
: redirect-to-action ( -- )
current-action session>
"form-failed" word-prop replace-variables
quot-link furnace-session-id build-url permanent-redirect ;
: if-form-page ( if then -- )
current-action session> "form-failed" word-prop -rot if ;
: do-action
current-action session> [ query>seq ] keep add >quotation call ;
: process-form ( -- )
H{ } clone validation-errors >session
request-params session> current-action session> query>seq
validators-errored session> [
drop redirect-to-action
] [
current-action session> add >quotation call
] if ;
: page-submitted ( -- )
[ process-form ] [ request-params session> do-action ] if-form-page ;
: action-first-time ( -- )
request-params session> current-action session>
[ "default-values" word-prop swap union request-params >session ] keep
request-params session> do-action ;
: page-not-submitted ( -- )
[ redirect-to-action ] [ action-first-time ] if-form-page ;
: setup-call-action ( hash word -- )
over lookup-session session set
current-action >session
request-params session> swap union
request-params >session
f validators-errored >session ;
: call-action ( hash word -- )
setup-call-action
"furnace-form-submitted" request-params session> at
[ page-submitted ] [ page-not-submitted ] if ;
: responder-vocab ( str -- newstr )
"webapps." swap append ;
: lookup-action ( str webapp -- word )
responder-vocab lookup dup [
dup "action" word-prop [ drop f ] unless
] when ;
: truncate-url ( str -- newstr )
CHAR: / over index [ head ] when* ;
: parse-action ( str -- word/f )
dup empty? [ drop default-action get ] when
truncate-url "responder" get lookup-action ;
: service-request ( hash str -- )
parse-action [
[ call-action ] [ <pre> print-error </pre> ] recover
] [
"404 no such action: " "argument" get append httpd-error
] if* ;
: service-get
"query" get swap service-request ;
: service-post
"response" get swap service-request ;
: web-app ( name defaul path -- )
[
template-path set
default-action set
"responder" set
[ service-get ] "get" set
[ service-post ] "post" set
] make-responder ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
SYMBOL: model
: with-slots ( model quot -- )
[
>r [ dup model set explode-tuple ] when* r> call
] with-scope ;
: render-component ( model template -- )
swap [ render-template ] with-slots ;
: browse-webapp-source ( vocab -- )
<a vocab browser-link-href =href a>
"Browse source" write
</a> ;
: send-resource ( name -- )
template-path get swap path+ resource-path <file-reader>
stdio get stream-copy ;
: render-link ( quot name -- )
<a swap quot-link =href a> write </a> ;
: session-var ( str -- newstr )
request-params session> at ;
: render ( str -- )
request-params session> at [ write ] when* ;
: render-error ( str error-str -- )
swap validation-errors session> at validation-error? [
write
] [
drop
] if ;

View File

@ -1 +0,0 @@
Doug Coleman

View File

@ -1,50 +0,0 @@
USING: assocs calendar init kernel math.parser
namespaces random boxes alarms combinators.lib ;
IN: furnace.sessions
SYMBOL: sessions
: timeout ( -- dt ) 20 minutes ;
[
H{ } clone sessions set-global
] "furnace.sessions" add-init-hook
: new-session-id ( -- str )
[ 4 big-random >hex ]
[ sessions get-global key? not ] generate ;
TUPLE: session id namespace alarm user-agent ;
: cancel-timeout ( session -- )
session-alarm ?box [ cancel-alarm ] [ drop ] if ;
: delete-session ( session -- )
sessions get-global delete-at*
[ cancel-timeout ] [ drop ] if ;
: touch-session ( session -- )
dup cancel-timeout
dup [ session-id delete-session ] curry timeout later
swap session-alarm >box ;
: <session> ( id -- session )
H{ } clone <box> f session construct-boa ;
: new-session ( -- session id )
new-session-id [
dup <session> [
[ sessions get-global set-at ] keep
touch-session
] keep
] keep ;
: get-session ( id -- session/f )
sessions get-global at*
[ dup touch-session ] when ;
: session> ( str -- obj )
session get session-namespace at ;
: >session ( value key -- )
session get session-namespace set-at ;

View File

@ -1 +0,0 @@
Action-based web framework

View File

@ -1 +0,0 @@
enterprise

View File

@ -1 +0,0 @@
Doug Coleman

View File

@ -1,30 +0,0 @@
IN: furnace.validator.tests
USING: kernel sequences tools.test furnace.validator furnace ;
[
123 f
] [
H{ { "foo" "123" } } { "foo" v-number } action-param
] unit-test
: validation-fails
[ action-param nip not ] append [ f ] swap unit-test ;
[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails
[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails
[ "ABCD" f ]
[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ]
unit-test
[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ]
validation-fails
[ "AB" f ]
[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ]
unit-test
[ "AB" f ]
[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ]
unit-test

View File

@ -1,43 +0,0 @@
! Copyright (C) 2006 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces math.parser ;
IN: furnace.validator
TUPLE: validation-error reason ;
: apply-validators ( string quot -- obj error/f )
[
call f
] [
dup validation-error? [ >r 2drop f r> ] [ rethrow ] if
] recover ;
: validation-error ( msg -- * )
\ validation-error construct-boa throw ;
: v-default ( obj value -- obj )
over empty? [ nip ] [ drop ] if ;
: v-required ( str -- str )
dup empty? [ "required" validation-error ] when ;
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
validation-error
] [
drop
] if ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
validation-error
] [
drop
] if ;
: v-number ( str -- n )
string>number [
"must be a number" validation-error
] unless* ;

View File

@ -1,11 +1,12 @@
IN: http.server.actions.tests
USING: http.server.actions tools.test math math.parser
multiline namespaces http io.streams.string http.server
sequences ;
sequences accessors ;
[ + ]
{ { "a" [ string>number ] } { "b" [ string>number ] } }
"GET" <action> "action-1" set
<action>
[ "a" get "b" get + ] >>get
{ { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
"action-1" set
STRING: action-request-test-1
GET http://foo/bar?a=12&b=13 HTTP/1.1
@ -19,9 +20,10 @@ blah
"action-1" get call-responder
] unit-test
[ "X" <repetition> concat append ]
{ { +path+ [ ] } { "xxx" [ string>number ] } }
"POST" <action> "action-2" set
<action>
[ +path+ get "xxx" get "X" <repetition> concat append ] >>post
{ { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
"action-2" set
STRING: action-request-test-2
POST http://foo/bar/baz HTTP/1.1

View File

@ -1,14 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots sequences kernel assocs combinators
http.server http hashtables namespaces ;
http.server http.server.validators http hashtables namespaces ;
IN: http.server.actions
SYMBOL: +path+
TUPLE: action quot params method ;
TUPLE: action get get-params post post-params revalidate ;
C: <action> action
: <action>
action construct-empty
[ <400> ] >>get
[ <400> ] >>post
[ <400> ] >>revalidate ;
: extract-params ( request path -- assoc )
>r dup method>> {
@ -16,15 +20,22 @@ C: <action> action
{ "POST" [ post-data>> query>assoc ] }
} case r> +path+ associate union ;
: push-params ( assoc action -- ... )
params>> [ first2 >r swap at r> call ] with each ;
: action-params ( request path param -- error? )
-rot extract-params validate-params ;
: get-action ( request path -- response )
action get get-params>> action-params
[ <400> ] [ action get get>> call ] if ;
: post-action ( request path -- response )
action get post-params>> action-params
[ action get revalidate>> ] [ action get post>> ] if call ;
M: action call-responder ( request path action -- response )
pick request set
pick method>> over method>> = [
>r extract-params r>
[ push-params ] keep
quot>> call
] [
3drop <400>
] if ;
action set
over request set
over method>>
{
{ "GET" [ get-action ] }
{ "POST" [ post-action ] }
} case ;

View File

@ -0,0 +1,129 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: new-slots html.elements http.server.validators
accessors namespaces kernel io farkup math.parser assocs
classes words tuples arrays sequences io.files
http.server.templating.fhtml splitting ;
IN: http.server.components
SYMBOL: components
TUPLE: component id ;
: component ( name -- component )
dup components get at
[ ] [ "No such component: " swap append throw ] ?if ;
GENERIC: validate* ( string component -- result )
GENERIC: render-view* ( value component -- )
GENERIC: render-edit* ( value component -- )
GENERIC: render-error* ( reason value component -- )
SYMBOL: values
: value values get at ;
: render-view ( component -- )
dup id>> value swap render-view* ;
: render-error ( error -- )
<span "error" =class span> write </span> ;
: render-edit ( component -- )
dup id>> value dup validation-error? [
dup reason>> swap value>> rot render-error*
] [
swap render-edit*
] if ;
: <component> ( id string -- component )
>r \ component construct-boa r> construct-delegate ; inline
TUPLE: string min max ;
: <string> ( id -- component ) string <component> ;
M: string validate*
[ min>> v-min-length ] keep max>> v-max-length ;
M: string render-view*
drop write ;
: render-input
<input "text" =type id>> dup =id =name =value input/> ;
M: string render-edit*
render-input ;
M: string render-error*
render-input render-error ;
TUPLE: text ;
: <text> ( id -- component ) <string> text construct-delegate ;
: render-textarea
<textarea id>> dup =id =name textarea> write </textarea> ;
M: text render-edit*
render-textarea ;
M: text render-error*
render-textarea render-error ;
TUPLE: farkup ;
: <farkup> ( id -- component ) <text> farkup construct-delegate ;
M: farkup render-view*
drop string-lines "\n" join convert-farkup write ;
TUPLE: number min max ;
: <number> ( id -- component ) number <component> ;
M: number validate*
>r v-number r> [ min>> v-min-value ] keep max>> v-max-value ;
M: number render-view*
drop number>string write ;
M: number render-edit*
>r number>string r> render-input ;
M: number render-error*
render-input render-error ;
: tuple>slots ( tuple -- alist )
dup class "slot-names" word-prop swap tuple-slots
2array flip ;
: with-components ( tuple components quot -- )
[
>r components set
dup tuple>slots values set
tuple set
r> call
] with-scope ; inline
TUPLE: form view-template edit-template components ;
: <form> ( id view-template edit-template -- form )
V{ } clone form construct-boa
swap \ component construct-boa
over set-delegate ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
M: form render-view* ( value form -- )
dup components>>
swap view-template>>
[ resource-path run-template-file ] curry
with-components ;
M: form render-edit* ( value form -- )
dup components>>
swap edit-template>>
[ resource-path run-template-file ] curry
with-components ;

View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.crud
USING: kernel namespaces db.tuples math.parser
http.server.actions accessors ;
: by-id ( class -- tuple )
construct-empty "id" get >>id ;
: <delete-action> ( class -- action )
<action>
{ { "id" [ string>number ] } } >>post-params
swap [ by-id delete-tuple f ] curry >>post ;

View File

@ -1,14 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db http.server kernel new-slots accessors
continuations namespaces ;
continuations namespaces destructors ;
IN: http.server.db
TUPLE: db-persistence responder db params ;
C: <db-persistence> db-persistence
: connect-db ( db-persistence -- )
dup db>> swap params>> make-db
dup db set
dup db-open
add-always-destructor ;
M: db-persistence call-responder
dup db>> over params>> make-db dup db-open [
db set responder>> call-responder
] with-disposal ;
dup connect-db responder>> call-responder ;

View File

@ -3,7 +3,8 @@
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
vocabs.loader debugger html continuations random combinators ;
vocabs.loader debugger html continuations random combinators
destructors ;
IN: http.server
GENERIC: call-responder ( request path responder -- response )
@ -135,7 +136,7 @@ SYMBOL: development-mode
swap method>> "HEAD" =
[ drop ] [ write-response-body ] if ;
: do-request ( request -- request )
: do-request ( request -- response )
[
dup dup path>> over host>>
find-virtual-host call-responder
@ -149,13 +150,18 @@ LOG: httpd-hit NOTICE
: log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ;
: handle-client ( -- )
default-timeout
: ?refresh-all ( -- )
development-mode get-global
[ global [ refresh-all ] bind ] when
read-request
dup log-request
do-request do-response ;
[ global [ refresh-all ] bind ] when ;
: handle-client ( -- )
[
default-timeout
?refresh-all
read-request
dup log-request
do-request do-response
] with-destructors ;
: httpd ( port -- )
internet-server "http.server"

View File

@ -1,9 +1,9 @@
USING: io io.files io.streams.string http.server.templating kernel tools.test
sequences ;
IN: http.server.templating.tests
USING: io io.files io.streams.string
http.server.templating.fhtml kernel tools.test sequences ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
"extra/http/server/templating/test/" swap append
"extra/http/server/templating/fhtml/test/" swap append
[
".fhtml" append resource-path
[ run-template-file ] with-string-writer

View File

@ -7,7 +7,7 @@ source-files debugger combinators math quotations generic
strings splitting accessors http.server.static http.server
assocs ;
IN: http.server.templating
IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating" ;

View File

@ -0,0 +1,4 @@
IN: http.server.validators.tests
USING: kernel sequences tools.test http.server.validators ;
[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test

View File

@ -0,0 +1,64 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces
math.parser assocs new-slots ;
IN: http.server.validators
TUPLE: validation-error value reason ;
: validation-error ( value reason -- * )
\ validation-error construct-boa throw ;
: with-validator ( string quot -- result error? )
[ f ] compose curry
[ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline
: validate-param ( name validator assoc -- error? )
swap pick
>r >r at r> with-validator swap r> set ;
: validate-params ( validators assoc -- error? )
[ validate-param ] curry { } assoc>map [ ] contains? ;
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
dup empty? [ "required" validation-error ] when ;
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
validation-error
] [
drop
] if ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
validation-error
] [
drop
] if ;
: v-number ( str -- n )
dup string>number [ ] [
"must be a number" validation-error
] ?if ;
: v-min-value ( str n -- str )
2dup < [
[ "must be at least " % # ] "" make
validation-error
] [
drop
] if ;
: v-max-value ( str n -- str )
2dup > [
[ "must be no more than " % # ] "" make
validation-error
] [
drop
] if ;