From b64cb2cb759cb503ce077223f38f14ccabc52a67 Mon Sep 17 00:00:00 2001 From: slava Date: Fri, 28 Apr 2006 01:36:29 +0000 Subject: [PATCH] Fix scoping problem in cont-responder --- contrib/httpd/cont-responder.factor | 518 ++++++++++++++-------------- library/unix/io.factor | 16 +- 2 files changed, 261 insertions(+), 273 deletions(-) diff --git a/contrib/httpd/cont-responder.factor b/contrib/httpd/cont-responder.factor index 908a20b7b7..cd4d70093c 100644 --- a/contrib/httpd/cont-responder.factor +++ b/contrib/httpd/cont-responder.factor @@ -1,29 +1,10 @@ ! Copyright (C) 2004 Chris Double. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: cont-responder +! See http://factorcode.org/license.txt for BSD license. + USING: http httpd math namespaces io - lists strings kernel html hashtables - parser generic sequences ; +lists strings kernel html hashtables +parser generic sequences ; +IN: cont-responder #! Used inside the session state of responders to indicate whether the #! next request should use the post-refresh-get pattern. It is set to @@ -31,95 +12,95 @@ USING: http httpd math namespaces io SYMBOL: post-refresh-get? : expiry-timeout ( -- timeout-seconds ) - #! Number of seconds to timeout continuations in - #! continuation table. This value will need to be - #! tuned. I leave it at 24 hours but it can be - #! higher/lower as needed. Default to 15 minutes for - #! testing. - 900 ; + #! Number of seconds to timeout continuations in + #! continuation table. This value will need to be + #! tuned. I leave it at 24 hours but it can be + #! higher/lower as needed. Default to 15 minutes for + #! testing. + 900 ; : get-random-id ( -- id ) - #! Generate a random id to use for continuation URL's - [ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ; + #! Generate a random id to use for continuation URL's + [ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ; SYMBOL: table : continuation-table ( -- ) - #! Return the global table of continuations - table global hash ; - -: reset-continuation-table ( -- ) - #! Create the initial global table - continuation-table clear-hash ; + #! Return the global table of continuations + table get-global ; -H{ } clone table global set-hash +: reset-continuation-table ( -- ) + #! Create the initial global table + continuation-table clear-hash ; + +H{ } clone table set-global #! Tuple for holding data related to a continuation. TUPLE: item expire? quot id time-added ; : continuation-item ( expire? quot id -- ) - #! A continuation item is the actual item stored - #! in the continuation table. It contains the id, - #! quotation/continuation, time added, etc. If - #! expire? is true then the continuation will - #! be expired after a certain amount of time. - millis ; + #! A continuation item is the actual item stored + #! in the continuation table. It contains the id, + #! quotation/continuation, time added, etc. If + #! expire? is true then the continuation will + #! be expired after a certain amount of time. + millis ; : seconds>millis ( seconds -- millis ) - #! Convert a number of seconds to milliseconds - 1000 * ; + #! Convert a number of seconds to milliseconds + 1000 * ; : expired? ( timeout-seconds -- bool ) - #! Return true if the continuation item is expirable - #! and has expired (ie. was added to the table more than - #! timeout milliseconds ago). - [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ; + #! Return true if the continuation item is expirable + #! and has expired (ie. was added to the table more than + #! timeout milliseconds ago). + [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ; : expire-continuations ( timeout-seconds -- ) - #! Expire all continuations in the continuation table - #! if they are 'timeout-seconds' old (ie. were added - #! more than 'timeout-seconds' ago. - continuation-table clone [ ( timeout-seconds [[ id item ]] -- ) - swapd expired? [ - continuation-table remove-hash - ] [ - drop - ] if - ] hash-each-with ; + #! Expire all continuations in the continuation table + #! if they are 'timeout-seconds' old (ie. were added + #! more than 'timeout-seconds' ago. + continuation-table clone [ + swapd expired? [ + continuation-table remove-hash + ] [ + drop + ] if + ] hash-each-with ; : expirable ( quot -- t quot ) - #! Set the stack up for a register-continuation call - #! so that the given quotation is registered that it can - #! be expired. - t swap ; + #! Set the stack up for a register-continuation call + #! so that the given quotation is registered that it can + #! be expired. + t swap ; : permanent ( quot -- f quot ) - #! Set the stack up for a register-continuation call - #! so that the given quotation is never expired after - #! registration. - f swap ; + #! Set the stack up for a register-continuation call + #! so that the given quotation is never expired after + #! registration. + f swap ; : register-continuation ( expire? quot -- id ) - #! Store a continuation in the table and associate it with - #! a random id. That continuation will be expired after - #! a certain period of time if 'expire?' is true. - get-random-id - [ continuation-item ] keep ( item id -- ) - [ continuation-table set-hash ] keep ; - + #! Store a continuation in the table and associate it with + #! a random id. That continuation will be expired after + #! a certain period of time if 'expire?' is true. + get-random-id + [ continuation-item ] keep ( item id -- ) + [ continuation-table set-hash ] keep ; + : register-continuation* ( expire? quots -- id ) - #! Like register-continuation but registers a quotation - #! that will call all quotations in the list, in the order given. - concat register-continuation ; + #! Like register-continuation but registers a quotation + #! that will call all quotations in the list, in the order given. + concat register-continuation ; : get-continuation-item ( id -- ) - #! Get the continuation item associated with the id. - continuation-table hash ; + #! Get the continuation item associated with the id. + continuation-table hash ; : id>url ( id -- string ) - #! Convert the continuation id to an URL suitable for - #! embedding in an HREF or other HTML. - url-encode "?id=" swap append ; + #! Convert the continuation id to an URL suitable for + #! embedding in an HREF or other HTML. + url-encode "?id=" swap append ; DEFER: show-final DEFER: show @@ -127,257 +108,262 @@ DEFER: show TUPLE: resume value stdio ; : (expired-page-handler) ( alist -- ) - #! Display a page has expired message. - #! TODO: Need to handle this better to enable - #! returning back to root continuation. + #! Display a page has expired message. + #! TODO: Need to handle this better to enable + #! returning back to root continuation. - -

"This page has expired." write

- + +

"This page has expired." write

+ flush ; : expired-page-handler ( alist -- ) - [ (expired-page-handler) ] show-final ; + [ (expired-page-handler) ] show-final ; : >callable ( quot|interp|f -- interp ) - dup continuation? [ - [ continue-with ] cons - ] when ; + dup continuation? [ + [ continue-with ] cons + ] when ; : get-registered-continuation ( id -- cont ) - #! Return the continuation or quotation - #! associated with the given id. - #! TODO: handle expired pages better. - expiry-timeout expire-continuations - get-continuation-item [ - item-quot - ] [ - [ (expired-page-handler) ] - ] if* >callable ; + #! Return the continuation or quotation + #! associated with the given id. + #! TODO: handle expired pages better. + expiry-timeout expire-continuations + get-continuation-item [ + item-quot + ] [ + [ (expired-page-handler) ] + ] if* >callable ; : resume-continuation ( resumed-data id -- ) - #! Call the continuation associated with the given id, - #! with 'value' on the top of the stack. - get-registered-continuation call ; + #! Call the continuation associated with the given id, + #! with 'value' on the top of the stack. + get-registered-continuation call ; #! Name of the variable holding the continuation used to exit #! back to the httpd responder, returning any generated HTML. SYMBOL: exit-cc : exit-continuation ( -- exit ) - #! Get the current exit continuation - exit-cc get ; + #! Get the current exit continuation + exit-cc get ; : call-exit-continuation ( value -- ) - #! Call the exit continuation, passing it the given value on the - #! top of the stack. - exit-cc get continue-with ; + #! Call the exit continuation, passing it the given value on the + #! top of the stack. + exit-cc get continue-with ; : with-exit-continuation ( quot -- ) - #! Call the quotation with the variable exit-cc bound such that when - #! the exit continuation is called, computation will resume from the - #! end of this 'with-exit-continuation' call, with the value passed - #! to the exit continuation on the top of the stack. - [ exit-cc set call f call-exit-continuation ] callcc1 nip ; + #! Call the quotation with the variable exit-cc bound such that when + #! the exit continuation is called, computation will resume from the + #! end of this 'with-exit-continuation' call, with the value passed + #! to the exit continuation on the top of the stack. + [ exit-cc set call f call-exit-continuation ] callcc1 nip ; #! Name of variable holding the 'callback' continuation, used for #! returning back to previous 'show' calls. SYMBOL: callback-cc : store-callback-cc ( -- ) - #! Store the current continuation in the variable 'callback-cc' - #! so it can be returned to later by callbacks. Note that it - #! recalls itself when the continuation is called to ensure that - #! it resets its value back to the most recent show call. - [ ( 0 -- ) - [ ( 0 1 -- ) - callback-cc set ( 0 -- ) - stdio get swap continue-with - ] callcc1 ( 0 [ ] == ) - nip - dup resume-stdio stdio set resume-value - call - store-callback-cc stdio get - ] callcc1 stdio set ; + #! Store the current continuation in the variable 'callback-cc' + #! so it can be returned to later by callbacks. Note that it + #! recalls itself when the continuation is called to ensure that + #! it resets its value back to the most recent show call. + [ ( 0 -- ) + [ ( 0 1 -- ) + callback-cc set ( 0 -- ) + stdio get swap continue-with + ] callcc1 + nip + dup resume-stdio stdio set resume-value + call + store-callback-cc stdio get + ] callcc1 stdio set ; : forward-to-url ( url -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - [ - "HTTP/1.1 302 Document Moved\nLocation: " % % - "\nContent-Length: 0\nContent-Type: text/plain\n\n" % - ] "" make write "" call-exit-continuation ; + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + [ + "HTTP/1.1 302 Document Moved\nLocation: " % % + "\nContent-Length: 0\nContent-Type: text/plain\n\n" % + ] "" make write "" call-exit-continuation ; : forward-to-id ( id -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - >r "request" get r> id>url append forward-to-url ; + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + >r "request" get r> id>url append forward-to-url ; : redirect-to-here ( -- ) - #! Force a redirect to the client browser so that the browser - #! goes to the current point in the code. This forces an URL - #! change on the browser so that refreshing that URL will - #! immediately run from this code point. This prevents the - #! "this request will issue a POST" warning from the browser - #! and prevents re-running the previous POST logic. This is - #! known as the 'post-refresh-get' pattern. - post-refresh-get? get [ - [ - expirable register-continuation forward-to-id - ] callcc1 resume-stdio stdio set - ] [ - t post-refresh-get? set - ] if ; + #! Force a redirect to the client browser so that the browser + #! goes to the current point in the code. This forces an URL + #! change on the browser so that refreshing that URL will + #! immediately run from this code point. This prevents the + #! "this request will issue a POST" warning from the browser + #! and prevents re-running the previous POST logic. This is + #! known as the 'post-refresh-get' pattern. + post-refresh-get? get [ + [ + expirable register-continuation forward-to-id + ] callcc1 resume-stdio stdio set + ] [ + t post-refresh-get? set + ] if ; : (show) ( quot -- namespace ) - #! See comments for show. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-callback-cc redirect-to-here - [ - expirable register-continuation id>url swap - with-scope "" call-exit-continuation - ] callcc1 - nip dup resume-stdio stdio set resume-value ; - + #! See comments for show. The difference is the + #! quotation MUST set the content-type using 'serving-html' + #! or similar. + store-callback-cc redirect-to-here + [ + expirable register-continuation id>url swap + with-scope "" call-exit-continuation + ] callcc1 + nip dup resume-stdio stdio set resume-value ; + : show ( quot -- namespace ) - #! Call the quotation with the URL associated with the current - #! continuation. All output from the quotation goes to the client - #! browser. When the URL is later referenced then - #! computation will resume from this 'show' call with a namespace on - #! the stack containing any query or post parameters. - #! NOTE: On return from 'show' the stack is exactly the same as - #! initial entry with 'quot' popped off an put on. Even - #! if the quotation consumes items on the stack. - \ serving-html swons (show) ; + #! Call the quotation with the URL associated with the current + #! continuation. All output from the quotation goes to the client + #! browser. When the URL is later referenced then + #! computation will resume from this 'show' call with a namespace on + #! the stack containing any query or post parameters. + #! NOTE: On return from 'show' the stack is exactly the same as + #! initial entry with 'quot' popped off an put on. Even + #! if the quotation consumes items on the stack. + \ serving-html swons (show) ; : (show-final) ( quot -- namespace ) - #! See comments for show-final. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-callback-cc redirect-to-here - with-scope "" call-exit-continuation ; + #! See comments for show-final. The difference is the + #! quotation MUST set the content-type using 'serving-html' + #! or similar. + store-callback-cc redirect-to-here + with-scope "" call-exit-continuation ; : show-final ( quot -- namespace ) - #! Similar to 'show', except the quotation does not receive the URL - #! to resume computation following 'show-final'. No continuation is - #! stored for this resumption. As a result, 'show-final' is for use - #! when a page is to be displayed with no further action to occur. Its - #! use is an optimisation to save having to generate and save a continuation - #! in that special case. - \ serving-html swons (show-final) ; + #! Similar to 'show', except the quotation does not receive the URL + #! to resume computation following 'show-final'. No continuation is + #! stored for this resumption. As a result, 'show-final' is for use + #! when a page is to be displayed with no further action to occur. Its + #! use is an optimisation to save having to generate and save a continuation + #! in that special case. + \ serving-html swons (show-final) ; #! Name of variable for holding initial continuation id that starts #! the responder. SYMBOL: root-continuation : id-or-root ( -- id ) - #! Return the continuation id for the current requested continuation - #! or the root continuation if no id is supplied. - "id" "query" get hash [ root-continuation get ] unless* ; + #! Return the continuation id for the current requested continuation + #! or the root continuation if no id is supplied. + "id" "query" get hash [ root-continuation get ] unless* ; : cont-get/post-responder ( id-or-f -- ) - #! httpd responder that retrieves a continuation and calls it. - #! The continuation id must be in a query parameter called 'id'. - #! If it does not exist the root continuation is called. If - #! no root continuation exists the expired continuation handler - #! should be called. - drop [ - "response" get stdio get - id-or-root [ - resume-continuation - ] [ - (expired-page-handler) "" call-exit-continuation - ] if* - ] with-exit-continuation drop ; + #! httpd responder that retrieves a continuation and calls it. + #! The continuation id must be in a query parameter called 'id'. + #! If it does not exist the root continuation is called. If + #! no root continuation exists the expired continuation handler + #! should be called. + [ + drop [ + "response" get stdio get + id-or-root [ + resume-continuation + ] [ + (expired-page-handler) "" call-exit-continuation + ] if* + ] with-exit-continuation drop + ] with-scope ; : callback-quot ( quot -- quot ) - #! Convert the given quotation so it works as a callback - #! by returning a quotation that will pass the original - #! quotation to the callback continuation. - [ , \ stdio , \ get , \ , callback-cc get , \ continue-with , ] [ ] make ; + #! Convert the given quotation so it works as a callback + #! by returning a quotation that will pass the original + #! quotation to the callback continuation. + [ + , \ stdio , \ get , \ , callback-cc get , + \ continue-with , + ] [ ] make ; : quot-url ( quot -- url ) - callback-quot expirable register-continuation id>url ; + callback-quot expirable register-continuation id>url ; : quot-href ( text quot -- ) - #! Write to standard output an HTML HREF where the href, - #! when referenced, will call the quotation and then return - #! back to the most recent 'show' call (via the callback-cc). - #! The text of the link will be the 'text' argument on the - #! stack. - write ; + #! Write to standard output an HTML HREF where the href, + #! when referenced, will call the quotation and then return + #! back to the most recent 'show' call (via the callback-cc). + #! The text of the link will be the 'text' argument on the + #! stack. + write ; : init-session-namespace ( -- ) - #! Setup the initial session namespace. Currently this only - #! sets the redirect flag so that the initial request of the - #! responder will not do a post-refresh-get style redirect. - #! This prevents the initial request to a responder from redirecting - #! to an URL with a continuation id. This word must be run from - #! within the session namespace. - f post-refresh-get? set dup resume-stdio stdio set ; + #! Setup the initial session namespace. Currently this only + #! sets the redirect flag so that the initial request of the + #! responder will not do a post-refresh-get style redirect. + #! This prevents the initial request to a responder from redirecting + #! to an URL with a continuation id. This word must be run from + #! within the session namespace. + f post-refresh-get? set dup resume-stdio stdio set ; : install-cont-responder ( name quot -- ) - #! Install a cont-responder with the given name - #! that will initially run the given quotation. - #! - #! Convert the quotation so it is run within a session namespace - #! and that namespace is initialized first. - \ init-session-namespace swons [ , \ with-scope , ] [ ] make - [ - [ cont-get/post-responder ] "get" set - [ cont-get/post-responder ] "post" set - swap "responder" set - permanent register-continuation root-continuation set - ] make-responder ; + #! Install a cont-responder with the given name + #! that will initially run the given quotation. + #! + #! Convert the quotation so it is run within a session namespace + #! and that namespace is initialized first. + \ init-session-namespace swons [ , \ with-scope , ] [ ] make + [ + [ cont-get/post-responder ] "get" set + [ cont-get/post-responder ] "post" set + swap "responder" set + permanent register-continuation root-continuation set + ] make-responder ; : simple-page ( title quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. - - swap write - call - ; + #! Call the quotation, with all output going to the + #! body of an html page with the given title. + + swap write + call + ; : styled-page ( title stylesheet-quot quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. stylesheet-quot - #! is called to generate the required stylesheet. - - - rot write - swap call - - call - ; + #! Call the quotation, with all output going to the + #! body of an html page with the given title. stylesheet-quot + #! is called to generate the required stylesheet. + + + rot write + swap call + + call + ; : paragraph ( str -- ) - #! Output the string as an html paragraph -

write

; + #! Output the string as an html paragraph +

write

; : show-message-page ( message -- ) - #! Display the message in an HTML page with an OK button. - [ - "Press OK to Continue" [ - swap paragraph - "OK" write - ] simple-page - ] show 2drop ; + #! Display the message in an HTML page with an OK button. + [ + "Press OK to Continue" [ + swap paragraph + "OK" write + ] simple-page + ] show 2drop ; : vertical-layout ( list -- ) - #! Given a list of HTML components, arrange them vertically. - + #! Given a list of HTML components, arrange them vertically. +
[ ] each -
call
; + ; : horizontal-layout ( list -- ) - #! Given a list of HTML components, arrange them horizontally. - - [ ] each -
call
; + #! Given a list of HTML components, arrange them horizontally. + + [ ] each +
call
; : button ( label -- ) - #! Output an HTML submit button with the given label. - ; + #! Output an HTML submit button with the given label. + ; diff --git a/library/unix/io.factor b/library/unix/io.factor index f1eeb6fa7a..a86fc78bd4 100644 --- a/library/unix/io.factor +++ b/library/unix/io.factor @@ -137,14 +137,16 @@ GENERIC: task-container ( task -- vector ) [ drop t swap rot set-bit-nth ] hash-each-with ; : init-fdsets ( -- read write except ) - read-fdset get [ read-tasks get init-fdset ] keep - write-fdset get [ write-tasks get init-fdset ] keep + read-fdset get-global + [ read-tasks get-global init-fdset ] keep + write-fdset get-global + [ write-tasks get-global init-fdset ] keep f ; : io-multiplex ( timeout -- ) >r FD_SETSIZE init-fdsets r> make-timeval select io-error - read-fdset get read-tasks get handle-fdset - write-fdset get write-tasks get handle-fdset ; + read-fdset get-global read-tasks get-global handle-fdset + write-fdset get-global write-tasks get-global handle-fdset ; ! Readers @@ -203,7 +205,7 @@ M: read-task do-io-task ( task -- ? ) 2drop f ] if ; -M: read-task task-container drop read-tasks get ; +M: read-task task-container drop read-tasks get-global ; : wait-to-read ( count port -- ) 2dup can-read-count? [ @@ -258,10 +260,10 @@ M: write-task do-io-task write-step f ] if ; -M: write-task task-container drop write-tasks get ; +M: write-task task-container drop write-tasks get-global ; : add-write-io-task ( callback task -- ) - dup io-task-fd write-tasks get hash [ + dup io-task-fd write-tasks get-global hash [ dup write-task? [ nip io-task-callbacks enque ] [