diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor
index 4c51e7ddfb..f96931c412 100755
--- a/extra/destructors/destructors-docs.factor
+++ b/extra/destructors/destructors-docs.factor
@@ -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" }
diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor
index 09b4ccc357..147e183688 100755
--- a/extra/destructors/destructors-tests.factor
+++ b/extra/destructors/destructors-tests.factor
@@ -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
diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor
index 0f8ec3af84..b2561c7439 100755
--- a/extra/destructors/destructors.factor
+++ b/extra/destructors/destructors.factor
@@ -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 -- )
diff --git a/extra/furnace/authors.txt b/extra/furnace/authors.txt
deleted file mode 100644
index f372b574ae..0000000000
--- a/extra/furnace/authors.txt
+++ /dev/null
@@ -1,2 +0,0 @@
-Slava Pestov
-Doug Coleman
diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor
deleted file mode 100755
index d8124d1f2b..0000000000
--- a/extra/furnace/furnace-tests.factor
+++ /dev/null
@@ -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
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
deleted file mode 100755
index 3bbd2d03da..0000000000
--- a/extra/furnace/furnace.factor
+++ /dev/null
@@ -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 ;
diff --git a/extra/furnace/sessions/authors.txt b/extra/furnace/sessions/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/extra/furnace/sessions/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
deleted file mode 100755
index cf03fee6b1..0000000000
--- a/extra/furnace/sessions/sessions.factor
+++ /dev/null
@@ -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 ;
diff --git a/extra/furnace/summary.txt b/extra/furnace/summary.txt
deleted file mode 100755
index 5696506f79..0000000000
--- a/extra/furnace/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Action-based web framework
diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt
deleted file mode 100644
index 0aef4feca8..0000000000
--- a/extra/furnace/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-enterprise
diff --git a/extra/furnace/validator/authors.txt b/extra/furnace/validator/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/extra/furnace/validator/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor
deleted file mode 100644
index e84e57be6a..0000000000
--- a/extra/furnace/validator/validator-tests.factor
+++ /dev/null
@@ -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
diff --git a/extra/furnace/validator/validator.factor b/extra/furnace/validator/validator.factor
deleted file mode 100644
index 698c77fa9a..0000000000
--- a/extra/furnace/validator/validator.factor
+++ /dev/null
@@ -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* ;
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
index 2d74e92e86..13089ae6e8 100644
--- a/extra/http/server/actions/actions-tests.factor
+++ b/extra/http/server/actions/actions-tests.factor
@@ -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
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index feb16a4488..5e5b7a9563 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -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 ;
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
new file mode 100644
index 0000000000..6fefb1b5dd
--- /dev/null
+++ b/extra/http/server/components/components.factor
@@ -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 ;
diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor
new file mode 100644
index 0000000000..099ded2f7f
--- /dev/null
+++ b/extra/http/server/crud/crud.factor
@@ -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 ;
diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor
index 4baee5f02b..511921ce06 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -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 ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index f397b280d0..990c77f71e 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -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"
diff --git a/extra/http/server/templating/authors.txt b/extra/http/server/templating/fhtml/authors.txt
similarity index 100%
rename from extra/http/server/templating/authors.txt
rename to extra/http/server/templating/fhtml/authors.txt
diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor
similarity index 65%
rename from extra/http/server/templating/templating-tests.factor
rename to extra/http/server/templating/fhtml/fhtml-tests.factor
index ceb2ed95be..0ae3b41454 100644
--- a/extra/http/server/templating/templating-tests.factor
+++ b/extra/http/server/templating/fhtml/fhtml-tests.factor
@@ -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
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/fhtml/fhtml.factor
similarity index 98%
rename from extra/http/server/templating/templating.factor
rename to extra/http/server/templating/fhtml/fhtml.factor
index b298faca74..37f4b85c51 100755
--- a/extra/http/server/templating/templating.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@@ -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" ;
diff --git a/extra/http/server/templating/test/bug.fhtml b/extra/http/server/templating/fhtml/test/bug.fhtml
similarity index 100%
rename from extra/http/server/templating/test/bug.fhtml
rename to extra/http/server/templating/fhtml/test/bug.fhtml
diff --git a/extra/http/server/templating/test/bug.html b/extra/http/server/templating/fhtml/test/bug.html
similarity index 100%
rename from extra/http/server/templating/test/bug.html
rename to extra/http/server/templating/fhtml/test/bug.html
diff --git a/extra/http/server/templating/test/example.fhtml b/extra/http/server/templating/fhtml/test/example.fhtml
similarity index 100%
rename from extra/http/server/templating/test/example.fhtml
rename to extra/http/server/templating/fhtml/test/example.fhtml
diff --git a/extra/http/server/templating/test/example.html b/extra/http/server/templating/fhtml/test/example.html
similarity index 100%
rename from extra/http/server/templating/test/example.html
rename to extra/http/server/templating/fhtml/test/example.html
diff --git a/extra/http/server/templating/test/stack.fhtml b/extra/http/server/templating/fhtml/test/stack.fhtml
similarity index 100%
rename from extra/http/server/templating/test/stack.fhtml
rename to extra/http/server/templating/fhtml/test/stack.fhtml
diff --git a/extra/http/server/templating/test/stack.html b/extra/http/server/templating/fhtml/test/stack.html
similarity index 100%
rename from extra/http/server/templating/test/stack.html
rename to extra/http/server/templating/fhtml/test/stack.html
diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor
new file mode 100644
index 0000000000..ff68dcfc64
--- /dev/null
+++ b/extra/http/server/validators/validators-tests.factor
@@ -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
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
new file mode 100644
index 0000000000..03beb8c3ff
--- /dev/null
+++ b/extra/http/server/validators/validators.factor
@@ -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 ;