From d286a7f4262869f6bd6a172443f07c5c708e6b6d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Aug 2009 10:31:00 -0500 Subject: [PATCH 1/7] compiler.cfg.critical-edges: no longer neededed --- .../critical-edges-tests.factor | 37 ------------------- .../cfg/critical-edges/critical-edges.factor | 29 --------------- 2 files changed, 66 deletions(-) delete mode 100644 basis/compiler/cfg/critical-edges/critical-edges-tests.factor delete mode 100644 basis/compiler/cfg/critical-edges/critical-edges.factor diff --git a/basis/compiler/cfg/critical-edges/critical-edges-tests.factor b/basis/compiler/cfg/critical-edges/critical-edges-tests.factor deleted file mode 100644 index 88383e2e1e..0000000000 --- a/basis/compiler/cfg/critical-edges/critical-edges-tests.factor +++ /dev/null @@ -1,37 +0,0 @@ -USING: accessors assocs compiler.cfg -compiler.cfg.critical-edges compiler.cfg.debugger -compiler.cfg.instructions compiler.cfg.predecessors -compiler.cfg.registers cpu.architecture kernel namespaces -sequences tools.test compiler.cfg.utilities ; -IN: compiler.cfg.critical-edges.tests - -! Make sure we update phi nodes when splitting critical edges - -: test-critical-edges ( -- ) - cfg new 0 get >>entry - compute-predecessors - split-critical-edges ; - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##phi f V int-regs 2 H{ { 0 V int-regs 0 } { 1 V int-regs 1 } } } - T{ ##return } -} 2 test-bb - -0 { 1 2 } edges -1 2 edge - -[ ] [ test-critical-edges ] unit-test - -[ t ] [ 0 get successors>> second successors>> first 2 get eq? ] unit-test - -[ V int-regs 0 ] [ 2 get instructions>> first inputs>> 0 get successors>> second swap at ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/critical-edges/critical-edges.factor b/basis/compiler/cfg/critical-edges/critical-edges.factor deleted file mode 100644 index 2a42df4bbf..0000000000 --- a/basis/compiler/cfg/critical-edges/critical-edges.factor +++ /dev/null @@ -1,29 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math accessors sequences locals assocs fry -compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ; -IN: compiler.cfg.critical-edges - -: critical-edge? ( from to -- ? ) - [ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ; - -: new-key ( new-key old-key assoc -- ) - [ delete-at* ] keep '[ swap _ set-at ] [ 2drop ] if ; - -:: update-phis ( from to bb -- ) - ! Any phi nodes in 'to' which reference 'from' - ! should now reference 'bb'. - to [ [ bb from ] dip inputs>> new-key ] each-phi ; - -: split-critical-edge ( from to -- ) - f [ insert-basic-block ] [ update-phis ] 3bi ; - -: split-critical-edges ( cfg -- ) - dup [ - dup successors>> [ - 2dup critical-edge? - [ split-critical-edge ] [ 2drop ] if - ] with each - ] each-basic-block - cfg-changed - drop ; \ No newline at end of file From 07ea78df5723f3130d19344bc836012d889381dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Aug 2009 13:30:55 -0500 Subject: [PATCH 2/7] sequences: map, 2map, 3map use new map-integers combinator; last two no longer depend on integers-as-sequences --- core/sequences/sequences.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 92a3495ba8..f0dc6d36c7 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -414,8 +414,11 @@ PRIVATE> : reduce ( seq identity quot -- result ) swapd each ; inline +: map-integers ( len quot exemplar -- newseq ) + [ over ] dip [ [ collect ] keep ] new-like ; inline + : map-as ( seq quot exemplar -- newseq ) - [ over length ] dip [ [ map-into ] keep ] new-like ; inline + [ (each) ] dip map-integers ; inline : map ( seq quot -- newseq ) over map-as ; inline @@ -442,7 +445,7 @@ PRIVATE> [ -rot ] dip 2each ; inline : 2map-as ( seq1 seq2 quot exemplar -- newseq ) - [ (2each) ] dip map-as ; inline + [ (2each) ] dip map-integers ; inline : 2map ( seq1 seq2 quot -- newseq ) pick 2map-as ; inline @@ -454,7 +457,7 @@ PRIVATE> (3each) each ; inline : 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq ) - [ (3each) ] dip map-as ; inline + [ (3each) ] dip map-integers ; inline : 3map ( seq1 seq2 seq3 quot -- newseq ) [ pick ] dip swap 3map-as ; inline From e5114aa510e423c0f0d99a30cd77076618090734 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Aug 2009 13:34:28 -0500 Subject: [PATCH 3/7] bootstrap.compiler.timing: fix load error --- basis/bootstrap/compiler/timing/timing.factor | 40 ++++++++++--------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/basis/bootstrap/compiler/timing/timing.factor b/basis/bootstrap/compiler/timing/timing.factor index e1466e3409..04c75c549d 100644 --- a/basis/bootstrap/compiler/timing/timing.factor +++ b/basis/bootstrap/compiler/timing/timing.factor @@ -1,38 +1,42 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors compiler.cfg.builder compiler.cfg.linear-scan -compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer -compiler.cfg.stacks.finalize compiler.cfg.stacks.global -compiler.codegen compiler.tree.builder compiler.tree.optimizer -kernel make sequences tools.annotations tools.crossref ; +USING: accessors kernel make sequences tools.annotations tools.crossref ; +QUALIFIED: compiler.cfg.builder +QUALIFIED: compiler.cfg.linear-scan +QUALIFIED: compiler.cfg.mr +QUALIFIED: compiler.cfg.optimizer +QUALIFIED: compiler.cfg.stacks.finalize +QUALIFIED: compiler.cfg.stacks.global +QUALIFIED: compiler.codegen +QUALIFIED: compiler.tree.builder +QUALIFIED: compiler.tree.optimizer IN: bootstrap.compiler.timing : passes ( word -- seq ) def>> uses [ vocabulary>> "compiler." head? ] filter ; -: high-level-passes ( -- seq ) \ optimize-tree passes ; +: high-level-passes ( -- seq ) \ compiler.tree.optimizer:optimize-tree passes ; -: low-level-passes ( -- seq ) \ optimize-cfg passes ; +: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ; -: machine-passes ( -- seq ) \ build-mr passes ; +: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ; -: linear-scan-passes ( -- seq ) \ (linear-scan) passes ; +: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ; : all-passes ( -- seq ) [ - \ build-tree , - \ optimize-tree , + \ compiler.tree.builder:build-tree , + \ compiler.tree.optimizer:optimize-tree , high-level-passes % - \ build-cfg , - \ compute-global-sets , - \ finalize-stack-shuffling , - \ optimize-cfg , + \ compiler.cfg.builder:build-cfg , + \ compiler.cfg.stacks.global:compute-global-sets , + \ compiler.cfg.stacks.finalize:finalize-stack-shuffling , + \ compiler.cfg.optimizer:optimize-cfg , low-level-passes % - \ compute-live-sets , - \ build-mr , + \ compiler.cfg.mr:build-mr , machine-passes % linear-scan-passes % - \ generate , + \ compiler.codegen:generate , ] { } make ; all-passes [ [ reset ] [ add-timing ] bi ] each \ No newline at end of file From 3857006b71220120c80f32f45510ac38aeb67192 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Aug 2009 14:58:18 -0500 Subject: [PATCH 4/7] Move furnace.actions:{param,params} and furnace.utilities:request-params to http.server --- basis/furnace/actions/actions-docs.factor | 18 ++------------ basis/furnace/actions/actions.factor | 12 +++------- basis/furnace/utilities/utilities-docs.factor | 5 ---- basis/furnace/utilities/utilities.factor | 7 ------ basis/http/server/server-docs.factor | 24 ++++++++++++++++++- basis/http/server/server.factor | 22 +++++++++++++++-- 6 files changed, 48 insertions(+), 40 deletions(-) diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor index 83ed00ca1b..451effddd8 100644 --- a/basis/furnace/actions/actions-docs.factor +++ b/basis/furnace/actions/actions-docs.factor @@ -33,18 +33,6 @@ HELP: new-action HELP: page-action { $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ; -HELP: param -{ $values - { "name" string } - { "value" string } -} -{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } -{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ; - -HELP: params -{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." } -{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ; - HELP: validate-integer-id { $description "A utility word which validates an integer parameter named " { $snippet "id" } "." } { $examples @@ -144,10 +132,8 @@ ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle" "Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ; ARTICLE: "furnace.actions.impl" "Furnace actions implementation" -"The following words are used by the action implementation and there is rarely any reason to call them directly:" -{ $subsection new-action } -{ $subsection param } -{ $subsection params } ; +"The following parametrized constructor should be called from constructors for subclasses of " { $link action } ":" +{ $subsection new-action } ; ARTICLE: "furnace.actions" "Furnace actions" "The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle." diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 06e743e967..aca03b9029 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -17,8 +17,6 @@ html.templates.chloe.syntax html.templates.chloe.compiler ; IN: furnace.actions -SYMBOL: params - SYMBOL: rest TUPLE: action rest init authorize display validate submit ; @@ -60,9 +58,6 @@ TUPLE: action rest init authorize display validate submit ; ] [ drop <400> ] if ] with-exit-continuation ; -: param ( name -- value ) - params get at ; - CONSTANT: revalidate-url-key "__u" : revalidate-url ( -- url/f ) @@ -88,13 +83,12 @@ CONSTANT: revalidate-url-key "__u" ] [ drop <400> ] if ] with-exit-continuation ; -: handle-rest ( path action -- assoc ) - rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; +: handle-rest ( path action -- ) + rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ; : init-action ( path action -- ) begin-form - handle-rest - request get request-params assoc-union params set ; + handle-rest ; M: action call-responder* ( path action -- response ) [ init-action ] keep diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index e7fdaf64d6..b00f7fa523 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -63,10 +63,6 @@ HELP: referrer { $values { "referrer/f" { $maybe string } } } { $description "Outputs the current request's referrer URL." } ; -HELP: request-params -{ $values { "request" request } { "assoc" assoc } } -{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; - HELP: resolve-base-path { $values { "string" string } { "string'" string } } { $description "Resolves a responder-relative URL." } ; @@ -121,6 +117,5 @@ ARTICLE: "furnace.misc" "Miscellaneous Furnace features" { $subsection exit-with } "Other useful words:" { $subsection hidden-form-field } -{ $subsection request-params } { $subsection client-state } { $subsection user-agent } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index a43466489c..dc90ad4e8c 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -91,13 +91,6 @@ M: object modify-form drop f ; CONSTANT: nested-forms-key "__n" -: request-params ( request -- assoc ) - dup method>> { - { "GET" [ url>> query>> ] } - { "HEAD" [ url>> query>> ] } - { "POST" [ post-data>> params>> ] } - } case ; - : referrer ( -- referrer/f ) #! Typo is intentional, it's in the HTTP spec! "referer" request get header>> at diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index daf0305972..e6d5c63ac1 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ; +USING: help.markup help.syntax io.streams.string quotations strings urls +http vocabs.refresh math io.servers.connection assocs ; IN: http.server HELP: trivial-responder @@ -52,12 +53,33 @@ HELP: httpd HELP: http-insomniac { $description "Starts a thread which rotates the logs and e-mails a summary of HTTP requests every 24 hours. See " { $link "logging.insomniac" } "." } ; +HELP: request-params +{ $values { "request" request } { "assoc" assoc } } +{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; + +HELP: param +{ $values + { "name" string } + { "value" string } +} +{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } +{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ; + +HELP: params +{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." } +{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ; + ARTICLE: "http.server.requests" "HTTP request variables" "The following variables are set by the HTTP server at the beginning of a request." { $subsection request } { $subsection url } { $subsection post-request? } { $subsection responder-nesting } +{ $subsection params } +"Utility words:" +{ $subsection param } +{ $subsection set-param } +{ $subsection request-params } "Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ; ARTICLE: "http.server.responders" "HTTP server responders" diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 8682c97c73..131fe3fe18 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -3,7 +3,8 @@ USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations combinators vocabs.refresh tools.time math math.parser present -io vectors +vectors hashtables +io io.sockets io.sockets.secure io.encodings @@ -212,8 +213,25 @@ LOG: httpd-header NOTICE : split-path ( string -- path ) "/" split harvest ; +: request-params ( request -- assoc ) + dup method>> { + { "GET" [ url>> query>> ] } + { "HEAD" [ url>> query>> ] } + { "POST" [ post-data>> params>> ] } + } case ; + +SYMBOL: params + +: param ( name -- value ) + params get at ; + +: set-param ( value name -- ) + params get set-at ; + : init-request ( request -- ) - [ request set ] [ url>> url set ] bi + [ request set ] + [ url>> url set ] + [ request-params >hashtable params set ] tri V{ } clone responder-nesting set ; : dispatch-request ( request -- response ) From 181d9ca07d6a56c5ae496ac94714c5e8a7a7e674 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Aug 2009 14:58:56 -0500 Subject: [PATCH 5/7] http.server.rewrite: facility for making URLs prettier, and dynamic dispatching on the first part of a host name. Doug go nuts --- basis/http/server/rewrite/rewrite-docs.factor | 72 +++++++++++++++++++ .../http/server/rewrite/rewrite-tests.factor | 48 +++++++++++++ basis/http/server/rewrite/rewrite.factor | 33 +++++++++ 3 files changed, 153 insertions(+) create mode 100644 basis/http/server/rewrite/rewrite-docs.factor create mode 100644 basis/http/server/rewrite/rewrite-tests.factor create mode 100644 basis/http/server/rewrite/rewrite.factor diff --git a/basis/http/server/rewrite/rewrite-docs.factor b/basis/http/server/rewrite/rewrite-docs.factor new file mode 100644 index 0000000000..478adbab69 --- /dev/null +++ b/basis/http/server/rewrite/rewrite-docs.factor @@ -0,0 +1,72 @@ +IN: http.server.rewrite +USING: help.syntax help.markup http.server ; + +HELP: rewrite +{ $class-description "The class of directory rewrite responders. The slots are as follows:" +{ $list + { { $slot "default" } " - the responder to call if no file name is provided." } + { { $slot "child" } " - the responder to call if a file name is provided." } + { { $slot "param" } " - the name of a request parameter which will store the first path component of the file name passed to the responder." } +} } ; + +HELP: +{ $values { "rewrite" rewrite } } +{ $description "Creates a new " { $link rewrite } " responder." } +{ $examples + { $code + "" + " >>default" + " >>child" + " \"comment_id\" >>param" + } +} ; + +HELP: vhost-rewrite +{ $class-description "The class of virtual host rewrite responders. The slots are as follows:" +{ $list + { { $slot "default" } " - the responder to call if no host name prefix is provided." } + { { $slot "child" } " - the responder to call if a host name prefix is provided." } + { { $slot "param" } " - the name of a request parameter which will store the first host name component of the host name passed to the responder." } + { { $slot "suffix" } " - the domain name suffix which will be chopped off the end of the request's host name in order to produce the parameter." } +} } ; + +HELP: +{ $values { "vhost-rewrite" vhost-rewrite } } +{ $description "Creates a new " { $link vhost-rewrite } " responder." } +{ $examples + { $code + "" + " >>default" + " >>child" + " \"blog_id\" >>param" + " \"blogs.vegan.net >>suffix" + } +} ; + +ARTICLE: "http.server.rewrite.overview" "Rewrite responder overview" +"Rewrite responders take the file name and turn it into a request parameter named by the " { $slot "param" } " slot before delegating to a child responder. If a file name is provided, it calls the responder in the " { $slot "child" } " slot. If no file name is provided, they call the default responder in the " { $slot "default" } " slot." +$nl +"For example, suppose you want to have the following website schema:" +{ $list +{ { $snippet "/posts/" } " - show a list of posts" } +{ { $snippet "/posts/factor_language" } " - show thread with ID " { $snippet "factor_language" } } +{ { $snippet "/posts/factor_language/1" } " - show first comment in the thread with ID " { $snippet "factor_language" } } +{ { $snippet "/animals" } ", ... - a bunch of other actions" } } +"One way to achieve this would be to have a nesting of responders as follows:" +{ $list +{ "A dispatcher at the top level" } + { "A " { $link rewrite } " as a child of the dispatcher under the name " { $snippet "posts" } ". The rewrite has the " { $slot "param" } " slot set to, say, " { $snippet "post_id" } ". The " { $slot "default" } " slot is set to a Furnace action which displays a list of posts." } + { "The child slot is set to a second " { $link rewrite } " instance, with " { $snippet "param" } " set to " { $snippet "comment_id" } ", the " { $slot "default" } " slot set to an action which displays a post identified by the " { $snippet "post_id" } " parameter, and the " { $snippet "child" } " slot set to an action which displays the comment identified by the " { $snippet "comment_id" } " parameter." } } +"Note that parameters can be extracted from the request using the " { $link param } " word, but most of the time you want to use " { $vocab-link "furnace.actions" } " instead." ; + +ARTICLE: "http.server.rewrite" "URL rewrite responders" +"The " { $vocab-link "http.server.rewrite" } " vocabulary defines two responder types which can help make website URLs more human-friendly." +{ $subsection "http.server.rewrite.overview" } +"Directory rewrite responders:" +{ $subsection rewrite } +{ $subsection } +"Virtual host rewrite responders -- these chop off the value in the " { $snippet "suffix" } " slot from the tail of the host name, and use the rest as the parameter value:" +{ $subsection vhost-rewrite } +{ $subsection } ; + +ABOUT: "http.server.rewrite" \ No newline at end of file diff --git a/basis/http/server/rewrite/rewrite-tests.factor b/basis/http/server/rewrite/rewrite-tests.factor new file mode 100644 index 0000000000..3a053c3a9c --- /dev/null +++ b/basis/http/server/rewrite/rewrite-tests.factor @@ -0,0 +1,48 @@ +USING: accessors arrays http.server http.server.rewrite kernel +namespaces tools.test urls ; +IN: http.server.rewrite.tests + +TUPLE: rewrite-test-default ; + +M: rewrite-test-default call-responder* + drop "DEFAULT!" 2array ; + +TUPLE: rewrite-test-child ; + +M: rewrite-test-child call-responder* + drop "rewritten-param" param 2array ; + +V{ } clone responder-nesting set +H{ } clone params set + + + rewrite-test-child new >>child + rewrite-test-default new >>default + "rewritten-param" >>param +"rewrite" set + +[ { { } "DEFAULT!" } ] [ { } "rewrite" get call-responder ] unit-test +[ { { } "xxx" } ] [ { "xxx" } "rewrite" get call-responder ] unit-test +[ { { "blah" } "xxx" } ] [ { "xxx" "blah" } "rewrite" get call-responder ] unit-test + + + rewrite-test-child new >>child + rewrite-test-default new >>default + "rewritten-param" >>param + "blogs.vegan.net" >>suffix +"rewrite" set + +[ { { } "DEFAULT!" } ] [ + URL" http://blogs.vegan.net" url set + { } "rewrite" get call-responder +] unit-test + +[ { { } "DEFAULT!" } ] [ + URL" http://www.blogs.vegan.net" url set + { } "rewrite" get call-responder +] unit-test + +[ { { } "erg" } ] [ + URL" http://erg.blogs.vegan.net" url set + { } "rewrite" get call-responder +] unit-test \ No newline at end of file diff --git a/basis/http/server/rewrite/rewrite.factor b/basis/http/server/rewrite/rewrite.factor new file mode 100644 index 0000000000..ec6b7efed2 --- /dev/null +++ b/basis/http/server/rewrite/rewrite.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors http.server kernel namespaces sequences +splitting urls ; +IN: http.server.rewrite + +TUPLE: rewrite param child default ; + +: ( -- rewrite ) + rewrite new ; + +M: rewrite call-responder* + over empty? [ default>> ] [ + [ [ first ] [ param>> ] bi* set-param ] + [ [ rest ] [ child>> ] bi* ] + 2bi + ] if + call-responder* ; + +TUPLE: vhost-rewrite suffix param child default ; + +: ( -- vhost-rewrite ) + vhost-rewrite new ; + +: sub-domain? ( vhost-rewrite url -- subdomain ? ) + swap suffix>> dup [ + [ host>> canonical-host ] [ "." prepend ] bi* ?tail + ] [ 2drop f f ] if ; + +M: vhost-rewrite call-responder* + dup url get sub-domain? + [ over param>> set-param child>> ] [ drop default>> ] if + call-responder ; \ No newline at end of file From 841fc3a89ae33d79609902a165a1a5156024c9b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Aug 2009 15:00:05 -0500 Subject: [PATCH 6/7] http.server.rewrite generalizes furnace.actions rest slot, so mention this in the docs --- basis/furnace/actions/actions-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor index 451effddd8..6468b8deb7 100644 --- a/basis/furnace/actions/actions-docs.factor +++ b/basis/furnace/actions/actions-docs.factor @@ -91,7 +91,7 @@ $nl ARTICLE: "furnace.actions.config" "Furnace action configuration" "Actions have the following slots:" { $table - { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } } + { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error. A more general facility can be found in the " { $vocab-link "http.server.rewrite" } " vocabulary." } } { { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } } { { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } } { { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } } From 5d19f868fb7b1ed30dc8cd092b6c9395c2227275 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Aug 2009 17:32:56 -0500 Subject: [PATCH 7/7] fix using list --- basis/http/server/rewrite/rewrite.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/http/server/rewrite/rewrite.factor b/basis/http/server/rewrite/rewrite.factor index ec6b7efed2..86c6f83ad5 100644 --- a/basis/http/server/rewrite/rewrite.factor +++ b/basis/http/server/rewrite/rewrite.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors http.server kernel namespaces sequences -splitting urls ; +USING: accessors http.server http.server.dispatchers kernel +namespaces sequences splitting urls ; IN: http.server.rewrite TUPLE: rewrite param child default ; @@ -30,4 +30,4 @@ TUPLE: vhost-rewrite suffix param child default ; M: vhost-rewrite call-responder* dup url get sub-domain? [ over param>> set-param child>> ] [ drop default>> ] if - call-responder ; \ No newline at end of file + call-responder ;