libs/httpd/cont-responder.factor

   1 ! Copyright (C) 2004 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: http httpd math namespaces io strings kernel html hashtables
   5        parser generic sequences callback-responder ;
   6 IN: cont-responder
   7
   8 #! Used inside the session state of responders to indicate whether the
   9 #! next request should use the post-refresh-get pattern. It is set to
  10 #! true after each request.
  11 SYMBOL: post-refresh-get?
  12
  13 : >callable ( quot|interp|f -- interp )
  14     dup continuation? [
  15         [ continue ] curry
  16     ] when ;
  17
  18 : forward-to-url ( url -- )
  19     #! When executed inside a 'show' call, this will force a
  20     #! HTTP 302 to occur to instruct the browser to forward to
  21     #! the request URL.
  22     [
  23         "HTTP/1.1 302 Document Moved\nLocation: " % %
  24         "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
  25     ] "" make write exit-continuation get continue ;
  26
  27 : forward-to-id ( id -- )
  28     #! When executed inside a 'show' call, this will force a
  29     #! HTTP 302 to occur to instruct the browser to forward to
  30     #! the request URL.
  31     >r "request" get r> id>url append forward-to-url ;
  32
  33 SYMBOL: current-show
  34
  35 : store-current-show ( -- )
  36   #! Store the current continuation in the variable 'current-show'
  37   #! so it can be returned to later by href callbacks. Note that it
  38   #! recalls itself when the continuation is called to ensure that
  39   #! it resets its value back to the most recent show call.
  40   [  ( 0 -- )
  41     [ ( 0 1 -- )
  42       current-show set ( 0 -- )
  43       continue
  44     ] callcc1 ! 0 [ ] ==
  45     nip
  46     restore-request
  47     call
  48     store-current-show
  49   ] callcc0 restore-request ;
  50
  51 : redirect-to-here ( -- )
  52   #! Force a redirect to the client browser so that the browser
  53   #! goes to the current point in the code. This forces an URL
  54   #! change on the browser so that refreshing that URL will
  55   #! immediately run from this code point. This prevents the
  56   #! "this request will issue a POST" warning from the browser
  57   #! and prevents re-running the previous POST logic. This is
  58   #! known as the 'post-refresh-get' pattern.
  59   post-refresh-get? get [
  60     [
  61       >callable t register-callback forward-to-url
  62     ] callcc1 drop restore-request
  63   ] [
  64     t post-refresh-get? set
  65   ] if ;
  66
  67 : (show) ( quot -- hashtable )
  68     #! See comments for show. The difference is the
  69     #! quotation MUST set the content-type using 'serving-html'
  70     #! or similar.
  71     store-current-show redirect-to-here
  72     [
  73         >callable t register-callback swap with-scope
  74         exit-continuation get  continue
  75     ] callcc0 drop restore-request "response" get ;
  76
  77 : show ( quot -- namespace )
  78     #! Call the quotation with the URL associated with the current
  79     #! continuation. All output from the quotation goes to the client
  80     #! browser. When the URL is later referenced then
  81     #! computation will resume from this 'show' call with a hashtable on
  82     #! the stack containing any query or post parameters.
  83     #! 'quot' has stack effect ( url -- )
  84     #! NOTE: On return from 'show' the stack is exactly the same as
  85     #! initial entry with 'quot' popped off and the hashtable pushed on. Even
  86     #! if the quotation consumes items on the stack.
  87     [ serving-html ] swap append (show) ;
  88
  89 : (show-final) ( quot -- namespace )
  90     #! See comments for show-final. The difference is the
  91     #! quotation MUST set the content-type using 'serving-html'
  92     #! or similar.
  93     store-current-show redirect-to-here
  94     with-scope exit-continuation get continue ;
  95
  96 : show-final ( quot -- namespace )
  97     #! Similar to 'show', except the quotation does not receive the URL
  98     #! to resume computation following 'show-final'. No continuation is
  99     #! stored for this resumption. As a result, 'show-final' is for use
 100     #! when a page is to be displayed with no further action to occur. Its
 101     #! use is an optimisation to save having to generate and save a continuation
 102     #! in that special case.
 103     #! 'quot' has stack effect ( -- ).
 104     [ serving-html ] swap append (show-final) ;
 105
 106 #! Name of variable for holding initial continuation id that starts
 107 #! the responder.
 108 SYMBOL: root-callback
 109
 110 : cont-get/post-responder ( id-or-f -- )
 111     #! httpd responder that handles the root continuation request.
 112     #! The requests for actual continuation are processed by the
 113     #! 'callback-responder'.
 114     [
 115         [ f post-refresh-get? set <request> request set root-callback get call ] with-scope
 116         exit-continuation get continue
 117     ] with-exit-continuation  drop ;
 118
 119 : quot-url ( quot -- url )
 120     current-show get [ continue-with ] curry curry t register-callback ;
 121
 122 : quot-href ( text quot -- )
 123     #! Write to standard output an HTML HREF where the href,
 124     #! when referenced, will call the quotation and then return
 125     #! back to the most recent 'show' call (via the callback-cc).
 126     #! The text of the link will be the 'text' argument on the
 127     #! stack.
 128     <a quot-url =href a> write </a> ;
 129
 130 : install-cont-responder ( name quot -- )
 131     #! Install a cont-responder with the given name
 132     #! that will initially run the given quotation.
 133     #!
 134     #! Convert the quotation so it is run within a session namespace
 135     #! and that namespace is initialized first.
 136     [
 137         [ cont-get/post-responder ] "get" set
 138         [ cont-get/post-responder ] "post" set
 139         swap "responder" set
 140         root-callback set
 141     ] make-responder ;
 142
 143 : simple-page ( title quot -- )
 144     #! Call the quotation, with all output going to the
 145     #! body of an html page with the given title.
 146     <html>
 147         <head> <title> swap write </title> </head>
 148         <body> call </body>
 149     </html> ;
 150
 151 : styled-page ( title stylesheet-quot quot -- )
 152     #! Call the quotation, with all output going to the
 153     #! body of an html page with the given title. stylesheet-quot
 154     #! is called to generate the required stylesheet.
 155     <html>
 156         <head>
 157              <title> rot write </title>
 158              swap call
 159         </head>
 160         <body> call </body>
 161     </html> ;
 162
 163 : paragraph ( str -- )
 164     #! Output the string as an html paragraph
 165     <p> write </p> ;
 166
 167 : show-message-page ( message -- )
 168     #! Display the message in an HTML page with an OK button.
 169     [
 170         "Press OK to Continue" [
 171             swap paragraph
 172             <a =href a> "OK" write </a>
 173         ] simple-page
 174     ] show 2drop ;
 175
 176 : vertical-layout ( list -- )
 177     #! Given a list of HTML components, arrange them vertically.
 178     <table>
 179     [ <tr> <td> call </td> </tr> ] each
 180     </table> ;
 181
 182 : horizontal-layout ( list -- )
 183     #! Given a list of HTML components, arrange them horizontally.
 184     <table>
 185      <tr "top" =valign tr> [ <td> call </td> ] each </tr>
 186     </table> ;
 187
 188 : button ( label -- )
 189     #! Output an HTML submit button with the given label.
 190     <input "submit" =type =value input/> ;