125 lines
4.3 KiB
Factor
125 lines
4.3 KiB
Factor
! Copyright (C) 2004 Chris Double.
|
|
! Copyright (C) 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: callback-responder
|
|
USING: hashtables html http httpd io kernel math namespaces
|
|
sequences ;
|
|
|
|
#! Name of the variable holding the continuation used to exit
|
|
#! back to the httpd responder.
|
|
SYMBOL: exit-continuation
|
|
|
|
#! Tuple to hold global request data. This gets passed to
|
|
#! the continuation when resumed so it can restore things
|
|
#! like 'stdio' so it writes to the correct socket.
|
|
TUPLE: request stream exitcc method url raw-query query header response ;
|
|
|
|
C: request ( -- request )
|
|
[ stdio get swap set-request-stream ] keep
|
|
[ "method" get swap set-request-method ] keep
|
|
[ "request" get swap set-request-url ] keep
|
|
[ "raw-query" get swap set-request-raw-query ] keep
|
|
[ "query" get swap set-request-query ] keep
|
|
[ "header" get swap set-request-header ] keep
|
|
[ "response" get swap set-request-response ] keep
|
|
[ exit-continuation get swap set-request-exitcc ] keep ;
|
|
|
|
: restore-request ( -- )
|
|
request get
|
|
dup request-stream stdio set
|
|
dup request-method "method" set
|
|
dup request-raw-query "raw-query" set
|
|
dup request-query "query" set
|
|
dup request-header "header" set
|
|
dup request-response "response" set
|
|
request-exitcc exit-continuation set ;
|
|
|
|
: update-request ( request new-request -- )
|
|
[ request-stream over set-request-stream ] keep
|
|
[ request-method over set-request-method ] keep
|
|
[ request-url over set-request-url ] keep
|
|
[ request-raw-query over set-request-raw-query ] keep
|
|
[ request-query over set-request-query ] keep
|
|
[ request-header over set-request-header ] keep
|
|
[ request-response over set-request-response ] keep
|
|
request-exitcc swap set-request-exitcc ;
|
|
|
|
: with-exit-continuation ( quot -- )
|
|
#! Call the quotation with the variable exit-continuation bound
|
|
#! such that when the exit continuation is called, computation
|
|
#! will resume from the end of this 'with-exit-continuation' call.
|
|
[
|
|
exit-continuation set call exit-continuation get continue
|
|
] callcc0 drop ;
|
|
|
|
: expiry-timeout ( -- ms ) 900 1000 * ;
|
|
|
|
: get-random-id ( -- id )
|
|
#! Generate a random id to use for continuation URL's
|
|
[ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
|
|
|
|
: callback-table ( -- <hashtable> )
|
|
#! Return the global table of continuations
|
|
\ callback-table get-global ;
|
|
|
|
: reset-callback-table ( -- )
|
|
#! Create the initial global table
|
|
H{ } clone \ callback-table set-global ;
|
|
|
|
reset-callback-table
|
|
|
|
#! Tuple for holding data related to a callback.
|
|
TUPLE: item quot expire? request id time-added ;
|
|
|
|
C: item ( quot expire? request id -- item )
|
|
millis over set-item-time-added
|
|
[ set-item-id ] keep
|
|
[ set-item-request ] keep
|
|
[ set-item-expire? ] keep
|
|
[ set-item-quot ] keep ;
|
|
|
|
: expired? ( item -- ? )
|
|
#! Return true if the callback item is expirable
|
|
#! and has expired (ie. was added to the table more than
|
|
#! timeout milliseconds ago).
|
|
[ item-time-added expiry-timeout + millis < ] keep
|
|
item-expire? and ;
|
|
|
|
: expire-callbacks ( -- )
|
|
#! Expire all continuations in the continuation table
|
|
#! if they are 'timeout-seconds' old (ie. were added
|
|
#! more than 'timeout-seconds' ago.
|
|
callback-table clone [
|
|
expired? [ callback-table remove-hash ] [ drop ] if
|
|
] hash-each ;
|
|
|
|
: id>url ( id -- string )
|
|
#! Convert the continuation id to an URL suitable for
|
|
#! embedding in an HREF or other HTML.
|
|
"/responder/callback/?id=" swap url-encode append ;
|
|
|
|
: register-callback ( quot expire? -- url )
|
|
#! 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.
|
|
request get get-random-id [ <item> ] keep
|
|
[ callback-table set-hash ] keep
|
|
id>url ;
|
|
|
|
: register-html-callback ( quot expire? -- url )
|
|
>r [ serving-html ] swap append r> register-callback ;
|
|
|
|
: callback-responder ( -- )
|
|
expire-callbacks
|
|
"id" query-param callback-table hash [
|
|
[
|
|
dup item-request [
|
|
<request> update-request
|
|
] when*
|
|
item-quot call
|
|
exit-continuation get continue
|
|
] with-exit-continuation drop
|
|
] [
|
|
"404 Callback not available" httpd-error
|
|
] if* ;
|