! cont-responder v0.3
!
! 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
USE: stdio
USE: unparse
USE: httpd
USE: httpd-responder
USE: random
USE: continuations
USE: format
USE: arithmetic
USE: namespaces
USE: stack
USE: combinators
USE: streams
USE: regexp
USE: lists
USE: strings
USE: html

: get-random-id ( -- id ) 
  #! Generate a random id to use for continuation URL's
  <% 16 [ random-digit % ] times %> ;

: continuation-table ( -- <namespace> ) 
  #! Return the global table of continuations
  "cont" get ;

: reset-continuation-table ( -- ) 
  #! Create the initial global table
  <namespace> "cont" set ;

: register-continuation ( quot -- id ) 
  #! Store a continuation in the table and associate it with
  #! a random id.
  continuation-table [ get-random-id  dup [ set ] dip ] bind ;

: get-registered-continuation ( id -- cont ) 
  #! Return the continuation associated with the given id.
  continuation-table [ get ] bind ;

: resume-continuation ( value id  -- ) 
  #! Call the continuation associated with the given id,
  #! with 'value' on the top of the stack.
  get-registered-continuation call ;

: exit-continuation ( -- exit ) 
  #! Get the current exit continuation
  "exit" get ;

: call-exit-continuation ( value -- ) 
  #! Call the exit continuation, passing it the given value on the
  #! top of the stack.
  "exit" get call ;

: with-exit-continuation ( quot -- ) 
  #! Call the quotation with the variable "exit" 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" set call call-exit-continuation ] callcc1 nip ;

: 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 it's value back to the most recent show call.
  [ 
    [ "callback-cc" set call ] callcc0 drop store-callback-cc
  ] callcc0 ;

: with-string-stream ( quot -- string ) 
  #! Call the quotation with standard output bound to a string output
  #! stream. Return the string on exit.
  <namespace> [ 
    "stdio" <string-output-stream> put call "stdio" get stream>str 
  ] bind ;

: show ( quot -- alist )   
  #! Call the quotation with the URL associated with the current
  #! continuation. Return the HTML string generated by that code
  #! to the exit continuation. When the URL is later referenced then 
  #! computation will resume from this 'show' call with a alist on
  #! the stack containing any query or post parameters.
  store-callback-cc
  [ 
    register-continuation swap with-string-stream
    call-exit-continuation 
  ] callcc1 
  nip ;

: cont-get-responder ( id -- ) 
  #! httpd responder that retrieves a continuation and calls it.
  [ f swap resume-continuation ] with-exit-continuation
  serving-html print drop ;

: post-request>alist ( post-request -- alist )
  #! Return an alist containing name/value pairs from the
  #! post data.
  dup "&" swap str-contains [
    "(.+)&(.+)" groups [ "(.+)=(.+)" groups uncons car cons ] inject 
  ] [
    "(.+)=(.+)" groups uncons car cons unit
  ] ifte ;

: cont-post-responder ( id -- )    
  #! httpd responder that retrieves a continuation for the given
  #! id and calls it with the POST data as an alist on the top
  #! of the stack.
  [ 
    read-post-request post-request>alist swap resume-continuation 
  ] with-exit-continuation
  serving-html print drop ;

: install-cont-responder ( -- )
  #! Install the cont-responder in the table of httpd responders
  "httpd-responders" get [ 
     <responder> [ 
       [ cont-get-responder ] "get" set 
       [ cont-post-responder ] "post" set 
       reset-continuation-table
     ] extend "cont" set 
  ] bind ;

: display-page ( title -- ) 
  #! Display a page with some text to test the cont-responder.
  #! The page has a link to the 'next' continuation.
  [ 
    swap [ 
      "<a href='" write write "'>Next</a>" write 
    ] html-document 
  ] show drop ;

: display-get-name-page ( -- name )
  #! Display a page prompting for input of a name and return that name.
  [ 
    "Enter your name" [
      "<form method='post' action='" write write "'>" write 
      "Name: <input type='text' name='name' size='20'>" write
      "<input type='submit' value='Ok'>" write
      "</form>" write      
    ] html-document
  ] show 
  "name" swap assoc ;

: test-cont-responder ( alist - )
  #! Test the cont-responder responder by displaying a few pages in a row.
  drop
  "Page one" display-page 
  "Hello " display-get-name-page cat2 display-page
  "Page three" display-page ;

: register-test-cont-responder ( -- id )
  #! Register the test-cont-responder word so that accessing the
  #! URL with the returned ID will call it.
  "httpd-responders" get [ 
    "cont" get [ 
      [ test-cont-responder ] register-continuation 
    ] bind 
  ] bind ;

: test-cont-responder2 ( alist - )
  #! Test the cont-responder responder by displaying a few pages in a loop.
  [ "one" "two" "three" "four" ] [ display-page ] each 
  "Done!" display-page ;

: register-test-cont-responder2 ( -- id )
  #! Register the test-cont-responder2 word so that accessing the
  #! URL with the returned ID will call it.
  "httpd-responders" get [ 
    "cont" get [ 
      [ test-cont-responder2 ] register-continuation 
    ] bind 
  ] bind ;

: 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.
  "<a href='" write 
  "callback-cc" get [ call ] cons append register-continuation write
  "'>" write
  write
  "</a>" write ;

: test-cont-responder3 ( alist - )
  #! Test the quot-href word by displaying a menu of the current
  #! test words. Note that we drop the 'url' argument to the show
  #! quotation as we don't link to a 'next' page.
  drop
  [ 
    drop     
    "Menu" [ 
      "<ol>" write
      "<li>" write
      "Test responder1" [ test-cont-responder ] quot-href 
      "</li>" write
      "<li>" write
      "Test responder2" [ test-cont-responder2 ] quot-href 
      "</li>" write
      "</ol>" write
    ] html-document 
  ] show drop ;

: register-test-cont-responder3 ( -- id )
  #! Register the test-cont-responder3 word so that accessing the
  #! URL with the returned ID will call it.
  "httpd-responders" get [ 
    "cont" get [ 
      [ test-cont-responder3 ] register-continuation 
    ] bind 
  ] bind ;

: init-cont-responder ( -- )
  #! Initialize and install the cont-responder
  install-cont-responder ;