! cont-responder v0.5
!
! 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: httpd
USE: httpd-responder
USE: arithmetic
USE: random
USE: continuations
USE: format
USE: namespaces
USE: stack
USE: combinators
USE: streams
USE: lists
USE: strings
USE: html
USE: kernel
USE: logic
USE: cont-html

: 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 1 hour for
  #! testing.
  3600 ;

: redirect-enabled? 
  #! Set to true if you want the post-redirect-get pattern
  #! implemented. See the redirect-to-here word for details.
  t ;

: 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
  "continuation-table" get ;

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

: continuation-item ( expire? quot id -- <item> )
  #! 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.
  <namespace> [
    "id" set
    "quot" set
    "expire?" set
    millis "time-added" set
  ] extend ;

: seconds>millis ( seconds -- millis )
  #! Convert a number of seconds to milliseconds
  1000 * ;

: expired? ( timeout-seconds <item> -- bool )
  #! Return true if the continuation item is expirable
  #! and has expired (ie. was added to the table more than
  #! timeout milliseconds ago).
  [ seconds>millis "time-added" get + millis - 0 < 
    "expire?" get and 
  ] bind ;

: continuation-items ( -- alist )
  #! Return an alist of all continuation items in the continuation
  #! table with the car as the id and the cdr as the item.
  continuation-table [ vars-values ] bind ;

: 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-items [ cdr dupd expired? not ] subset nip
  alist>namespace "continuation-table" set ;

: 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.  
  continuation-table [ 
    get-random-id -rot pick continuation-item over set 
  ] bind ;
  
: append* ( lists -- list )
  #! Given a list of lists, append the lists together
  #! and return the concatenated list.
  f swap [ append ] each ;
  
: register-continuation* ( expire? quots -- id ) 
  #! Like register-continuation but registers a quotation 
  #! that will call all quotations in the list, in the order given.
  append* register-continuation ;

: get-continuation-item ( id -- <item> )
  #! Get the continuation item associated with the id.
  continuation-table [ get ] bind ;

DEFER: show 

: expired-page-handler ( alist -- )
  #! Display a page has expired message.
  #! TODO: Need to handle this better to enable
  #!       returning back to root continuation.
  drop
  [ 
    drop
    <html> [               
      <body> [
       <p> [ "This page has expired." write ] </p> 
      ] </body>
    ] </html> 
  ] show drop ;

: 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 dup [
    [ "quot" get ] bind 
  ] [
   drop [ expired-page-handler ]
  ] ifte ;

: 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 f 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 its value back to the most recent show call.
  [  ( 0 -- )
    [ ( 0 1 -- )
      "callback-cc" set ( 0 -- )
      call 
    ] callcc1 ( 0 [ ] == )
    nip
    call 
    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" 1024 <string-output-stream> put call "stdio" get stream>str 
  ] bind ;

: 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.
  "disable-initial-redirect?" get [
    "disable-initial-redirect?" f put 
  ] [
    [ 
      t swap register-continuation 
      <% "HTTP/1.1 302 Document Moved\nLocation: " % % "\n" % 
        "Content-Length: 0\nContent-Type: text/plain\n\n" % %>
      call-exit-continuation 
    ] callcc1 drop 
  ] ifte ;
  
: show ( quot -- namespace )   
  #! 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 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 <namespace> put on. Even
  #! if the quotation consumes items on the stack.
  store-callback-cc
  redirect-enabled? [ redirect-to-here ] when
  [ 
    t swap register-continuation swap 
    [ serving-html ] car swons with-string-stream
    call-exit-continuation 
  ] callcc1 
  nip ;

: cont-get-responder ( id -- ) 
  #! httpd responder that retrieves a continuation and calls it.
  dup f-or-"" [
    #! No continuation id given
    drop "root-continuation" get dup [
      #! Use the root continuation
      [ f swap resume-continuation ] with-exit-continuation
    ] [
      #! No root continuation either
      drop [ f expired-page-handler ] with-exit-continuation
    ] ifte
  ] [
    #! Use the given continuation  
    [ f swap resume-continuation ] with-exit-continuation
  ] ifte 
  [ print ] when* drop ;

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

: post-request>namespace ( post-request -- namespace )
  #! Return a namespace containing the name/value's from the 
  #! post data.
  post-request>alist alist>namespace ;

: 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>namespace swap resume-continuation 
  ] with-exit-continuation
  print drop ;

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

: with-new-session ( quot -- )
  #! Each cont-responder is bound inside their own
  #! namespace for storing session state. Run the given
  #! quotation inside a new namespace for this purpose.
  <namespace> swap bind ;

: init-session-namespace ( -- )
  #! Setup the initial session namespace. Currently this only
  #! copies the global value of whether the initial redirect
  #! will be disabled. It assumes the session namespace is
  #! topmost on the namespace stack.
  "disable-initial-redirect?" get "disable-initial-redirect?" set ;

: install-cont-responder ( name quot -- )
  #! Install a cont-responder with the given name
  #! that will initially run the given quotation.
  #!
  #! Convert the quotation os it is run within a session namespace
  #! and that namespace is initialized first.
  [ init-session-namespace ] swap append unit [ with-new-session ] append
  "httpd-responders" get [ 
     <responder> [ 
       [ cont-get-responder ] "get" set 
       [ cont-post-responder ] "post" set 
       reset-continuation-table 
       "disable-initial-redirect?" t put 
       f swap register-continuation "root-continuation" set 
       dup "responder-name" set
     ] extend put
  ] bind ;