From: John Benediktsson Date: Mon, 22 Jan 2018 22:20:57 +0000 (-0800) Subject: cont-responder: move to furnace.callbacks to match IN: declaration. X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor-unmaintained.git;a=commitdiff_plain;h=6f6d3b4573d803a8fb5cdff3d9d313687d8dde0e cont-responder: move to furnace.callbacks to match IN: declaration. --- diff --git a/cont-responder/callbacks-tests.factor b/cont-responder/callbacks-tests.factor deleted file mode 100644 index f9302de..0000000 --- a/cont-responder/callbacks-tests.factor +++ /dev/null @@ -1,67 +0,0 @@ -USING: furnace furnace.actions furnace.callbacks accessors -http http.server http.server.responses tools.test -namespaces io fry sequences -splitting kernel hashtables continuations ; -IN: furnace.callbacks.tests - -[ 123 ] [ - [ - "GET" >>method init-request - [ - exit-continuation set - { } - [ [ "hello" print 123 ] show-final ] >>display - - call-responder - ] callcc1 - ] with-scope -] unit-test - -[ - [ - [ - "hello" print - - ] show-page - "byebye" print - [ 123 ] show-final - ] >>display - "r" set - - [ 123 ] [ - init-request - - [ - exit-continuation set - "GET" >>method init-request - { } "r" get call-responder - ] callcc1 - - body>> first - - - "GET" >>method - dup url>> rot cont-id associate >>query drop - dup url>> "/" >>path drop - init-request - - [ - exit-continuation set - { } - "r" get call-responder - ] callcc1 - - ! get-post-get - - "GET" >>method - dup url>> rot "location" header query>> >>query drop - dup url>> "/" >>path drop - init-request - - [ - exit-continuation set - { } - "r" get call-responder - ] callcc1 - ] unit-test -] with-scope diff --git a/cont-responder/callbacks.factor b/cont-responder/callbacks.factor deleted file mode 100644 index 088ae6d..0000000 --- a/cont-responder/callbacks.factor +++ /dev/null @@ -1,122 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! Copyright (C) 2006, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: http http.server io kernel math namespaces -continuations calendar sequences assocs hashtables -accessors arrays alarms quotations combinators fry -http.server.redirection furnace assocs.lib urls ; -IN: furnace.callbacks - -SYMBOL: responder - -TUPLE: callback-responder responder callbacks ; - -: ( responder -- responder' ) - H{ } clone callback-responder boa ; - -TUPLE: callback cont quot expires alarm responder ; - -: timeout 20 minutes ; - -: timeout-callback ( callback -- ) - [ alarm>> cancel-alarm ] - [ dup responder>> callbacks>> delete-at ] - bi ; - -: touch-callback ( callback -- ) - dup expires>> [ - dup alarm>> [ cancel-alarm ] when* - dup '[ , timeout-callback ] timeout later >>alarm - ] when drop ; - -: ( cont quot expires? -- callback ) - f callback-responder get callback boa - dup touch-callback ; - -: invoke-callback ( callback -- response ) - [ touch-callback ] - [ quot>> request get exit-continuation get 3array ] - [ cont>> continue-with ] - tri ; - -: register-callback ( cont quot expires? -- id ) - callback-responder get callbacks>> set-at-unique ; - -: 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. - exit-with ; - -: cont-id "factorcontid" ; - -: 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. - - swap cont-id set-query-param forward-to-url ; - -: restore-request ( pair -- ) - first3 exit-continuation set request set call ; - -SYMBOL: post-refresh-get? - -: 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 [ - [ - [ ] t register-callback forward-to-id - ] callcc1 restore-request - ] [ - post-refresh-get? on - ] if ; - -SYMBOL: current-show - -: store-current-show ( -- ) - ! Store the current continuation in the variable 'current-show' - ! so it can be returned to later by 'quot-id'. Note that it - ! recalls itself when the continuation is called to ensure that - ! it resets its value back to the most recent show call. - [ current-show set f ] callcc1 - [ restore-request store-current-show ] when* ; - -: show-final ( quot -- * ) - [ redirect-to-here store-current-show ] dip - call exit-with ; inline - -: resuming-callback ( responder request -- id ) - url>> cont-id query-param swap callbacks>> at ; - -M: callback-responder call-responder* ( path responder -- response ) - '[ - , , - - [ callback-responder set ] - [ request get resuming-callback ] bi - - [ - invoke-callback - ] [ - callback-responder get responder>> call-responder - ] ?if - ] with-exit-continuation ; - -: show-page ( quot -- ) - [ redirect-to-here store-current-show ] dip - [ - [ ] t register-callback swap call exit-with - ] callcc1 restore-request ; inline - -: quot-id ( quot -- id ) - current-show get swap t register-callback ; - -: quot-url ( quot -- url ) - quot-id f swap cont-id associate derive-url ; diff --git a/furnace/callbacks/callbacks-tests.factor b/furnace/callbacks/callbacks-tests.factor new file mode 100644 index 0000000..f9302de --- /dev/null +++ b/furnace/callbacks/callbacks-tests.factor @@ -0,0 +1,67 @@ +USING: furnace furnace.actions furnace.callbacks accessors +http http.server http.server.responses tools.test +namespaces io fry sequences +splitting kernel hashtables continuations ; +IN: furnace.callbacks.tests + +[ 123 ] [ + [ + "GET" >>method init-request + [ + exit-continuation set + { } + [ [ "hello" print 123 ] show-final ] >>display + + call-responder + ] callcc1 + ] with-scope +] unit-test + +[ + [ + [ + "hello" print + + ] show-page + "byebye" print + [ 123 ] show-final + ] >>display + "r" set + + [ 123 ] [ + init-request + + [ + exit-continuation set + "GET" >>method init-request + { } "r" get call-responder + ] callcc1 + + body>> first + + + "GET" >>method + dup url>> rot cont-id associate >>query drop + dup url>> "/" >>path drop + init-request + + [ + exit-continuation set + { } + "r" get call-responder + ] callcc1 + + ! get-post-get + + "GET" >>method + dup url>> rot "location" header query>> >>query drop + dup url>> "/" >>path drop + init-request + + [ + exit-continuation set + { } + "r" get call-responder + ] callcc1 + ] unit-test +] with-scope diff --git a/furnace/callbacks/callbacks.factor b/furnace/callbacks/callbacks.factor new file mode 100644 index 0000000..088ae6d --- /dev/null +++ b/furnace/callbacks/callbacks.factor @@ -0,0 +1,122 @@ +! Copyright (C) 2004 Chris Double. +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http http.server io kernel math namespaces +continuations calendar sequences assocs hashtables +accessors arrays alarms quotations combinators fry +http.server.redirection furnace assocs.lib urls ; +IN: furnace.callbacks + +SYMBOL: responder + +TUPLE: callback-responder responder callbacks ; + +: ( responder -- responder' ) + H{ } clone callback-responder boa ; + +TUPLE: callback cont quot expires alarm responder ; + +: timeout 20 minutes ; + +: timeout-callback ( callback -- ) + [ alarm>> cancel-alarm ] + [ dup responder>> callbacks>> delete-at ] + bi ; + +: touch-callback ( callback -- ) + dup expires>> [ + dup alarm>> [ cancel-alarm ] when* + dup '[ , timeout-callback ] timeout later >>alarm + ] when drop ; + +: ( cont quot expires? -- callback ) + f callback-responder get callback boa + dup touch-callback ; + +: invoke-callback ( callback -- response ) + [ touch-callback ] + [ quot>> request get exit-continuation get 3array ] + [ cont>> continue-with ] + tri ; + +: register-callback ( cont quot expires? -- id ) + callback-responder get callbacks>> set-at-unique ; + +: 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. + exit-with ; + +: cont-id "factorcontid" ; + +: 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. + + swap cont-id set-query-param forward-to-url ; + +: restore-request ( pair -- ) + first3 exit-continuation set request set call ; + +SYMBOL: post-refresh-get? + +: 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 [ + [ + [ ] t register-callback forward-to-id + ] callcc1 restore-request + ] [ + post-refresh-get? on + ] if ; + +SYMBOL: current-show + +: store-current-show ( -- ) + ! Store the current continuation in the variable 'current-show' + ! so it can be returned to later by 'quot-id'. Note that it + ! recalls itself when the continuation is called to ensure that + ! it resets its value back to the most recent show call. + [ current-show set f ] callcc1 + [ restore-request store-current-show ] when* ; + +: show-final ( quot -- * ) + [ redirect-to-here store-current-show ] dip + call exit-with ; inline + +: resuming-callback ( responder request -- id ) + url>> cont-id query-param swap callbacks>> at ; + +M: callback-responder call-responder* ( path responder -- response ) + '[ + , , + + [ callback-responder set ] + [ request get resuming-callback ] bi + + [ + invoke-callback + ] [ + callback-responder get responder>> call-responder + ] ?if + ] with-exit-continuation ; + +: show-page ( quot -- ) + [ redirect-to-here store-current-show ] dip + [ + [ ] t register-callback swap call exit-with + ] callcc1 restore-request ; inline + +: quot-id ( quot -- id ) + current-show get swap t register-callback ; + +: quot-url ( quot -- url ) + quot-id f swap cont-id associate derive-url ;