Merge branch 'master' of git://factorcode.org/git/factor
Sam Anklesaria
commit
1145f49a47
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 <simple-block> [ 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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -103,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 } "." } }
|
||||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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: <rewrite>
|
||||
{ $values { "rewrite" rewrite } }
|
||||
{ $description "Creates a new " { $link rewrite } " responder." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"<rewrite>"
|
||||
" <display-post-action> >>default"
|
||||
" <display-comment-action> >>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: <vhost-rewrite>
|
||||
{ $values { "vhost-rewrite" vhost-rewrite } }
|
||||
{ $description "Creates a new " { $link vhost-rewrite } " responder." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"<vhost-rewrite>"
|
||||
" <show-blogs-action> >>default"
|
||||
" <display-blog-action> >>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 <rewrite> }
|
||||
"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 <vhost-rewrite> } ;
|
||||
|
||||
ABOUT: "http.server.rewrite"
|
||||
|
|
@ -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>
|
||||
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
|
||||
|
||||
<vhost-rewrite>
|
||||
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
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors http.server http.server.dispatchers kernel
|
||||
namespaces sequences splitting urls ;
|
||||
IN: http.server.rewrite
|
||||
|
||||
TUPLE: rewrite param child default ;
|
||||
|
||||
: <rewrite> ( -- 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 )
|
||||
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 ;
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue