http.server form validation
Slava Pestov
parent
b6b8ab32b5
commit
2feda7c5d7
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -1,2 +0,0 @@
|
|||
Slava Pestov
|
||||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Action-based web framework
|
||||
|
|
@ -1 +0,0 @@
|
|||
enterprise
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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* ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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" ;
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
Loading…
Reference in New Issue