examples/web-server/web-server.scm

   1 #!/usr/bin/env gsi-script
   2
   3 ; File: "web-server.scm", Time-stamp: <2008-12-17 13:41:03 feeley>
   4
   5 ; Copyright (c) 2004-2008 by Marc Feeley, All Rights Reserved.
   6
   7 ; A minimal web server which implements a web-site with a few
   8 ; interesting examples.
   9
  10 ;==============================================================================
  11
  12 (##include "~~lib/gambit#.scm") ;; import Gambit procedures and variables
  13 (##include "http#.scm")         ;; import HTTP procedures and variables
  14 (##include "html#.scm")         ;; import HTML procedures and variables
  15 (##include "base64#.scm")       ;; import BASE64 procedures and variables
  16
  17 (declare (block)) ;; required for serializing continuations
  18                   ;; (for the web-continuation example)
  19
  20 ;==============================================================================
  21
  22 (define main
  23   (lambda (arg)
  24     (let ((port-number
  25            (string->number arg)))
  26       (http-server-start!
  27        (make-http-server
  28         port-number: port-number
  29         threaded?: #t
  30         GET: GET/POST
  31         POST: GET/POST)))))
  32
  33 (define page-generators (make-table test: string=?))
  34
  35 (define show-exceptions
  36   (lambda (thunk)
  37     (with-exception-catcher
  38      (lambda (exc)
  39        (reply-html
  40         (<html>
  41          (<head> (<title> "Scheme exception"))
  42          (<body>
  43           (<p> "The following Scheme exception occurred while processing the request:")
  44           (<pre>
  45            (call-with-output-string
  46             ""
  47             (lambda (port) (##display-exception exc port))))))))
  48      thunk)))
  49
  50 (define GET/POST
  51   (lambda ()
  52     (show-exceptions
  53      (lambda ()
  54        (let* ((request (current-request))
  55               (uri (request-uri request))
  56               (path (uri-path uri))
  57               (generator (table-ref page-generators path unknown-page)))
  58          (generator))))))
  59
  60 (define unknown-page
  61   (lambda ()
  62     (let* ((request (current-request))
  63            (uri (request-uri request))
  64            (path (uri-path uri)))
  65       (get-filesys-path path))))
  66
  67 (define get-filesys-path
  68   (lambda (path)
  69     (let ((type (file-type path)))
  70       (case type
  71
  72         ((directory)
  73          (reply-html
  74           (<html>
  75            (<head> (<title> "Files in directory " path))
  76            (<body>
  77
  78             (<h1> "Files in " path)
  79
  80             (<ol>
  81              (map (lambda (fn)
  82                     (<li>
  83                      (<a> href: (object->string (path-expand fn path)) fn)
  84                      " ("
  85                      (object->string
  86                       (with-exception-catcher
  87                        (lambda (exc) 'other)
  88                        (lambda () (file-type (path-expand fn path)))))
  89                      ")"))
  90                   (directory-files
  91                    (list path: path ignore-hidden: #f))))))))
  92
  93         ((regular)
  94          (let* ((port (open-input-file path))
  95                 (file (read-line port #f)))
  96            (close-input-port port)
  97            (let ((ext (path-extension path)))
  98              (if (or (string-ci=? ext ".htm")
  99                      (string-ci=? ext ".html"))
 100                  (reply (lambda () (display file)))
 101                  (reply-html
 102                   (<html>
 103                    (<head> (<title> "File " path))
 104                    (<body> (<pre> file))))))))
 105
 106         (else
 107          (reply-html
 108           (<html>
 109            (<head> (<title> "Error"))
 110            (<body>
 111             "Only directories and regular files can be displayed"))))))))
 112
 113 ;==============================================================================
 114
 115 ; Main web page.
 116
 117 (define page-main
 118   (lambda ()
 119     (reply-html
 120      (<html>
 121       (<head> (<title> "Main page"))
 122       (<body>
 123        (<center> (<b> "Welcome to the " (<i> "web-server") " example"))
 124        (<p> "Please choose one of these examples:")
 125        (<ul>
 126         (<li> (<a> href: (object->string (current-directory))
 127                    "Browse the web server's filesystem"))
 128         (<li> (<a> href: "/web-continuation"
 129                    "Web-continuation based calculator"))
 130         (<li> (<a> href: "/terminate-server"
 131                    "Terminate server"))))))))
 132
 133 (table-set! page-generators "/"           page-main)
 134 (table-set! page-generators "/index.html" page-main)
 135 (table-set! page-generators "/index.htm"  page-main)
 136
 137 ;==============================================================================
 138
 139 ; Web pages for web-continuation example.
 140
 141 (define page-web-continuation
 142   (lambda ()
 143     (obtain-store-cont-on-server title-embed)))
 144
 145 (table-set! page-generators "/web-continuation" page-web-continuation)
 146
 147 (define page-calculator
 148   (lambda ()
 149
 150     ; check if we are resuming a continuation or starting the example
 151
 152     (let* ((request (current-request))
 153            (query (request-query request)))
 154
 155       (cond ((and query (assoc "cont" query))
 156              =>
 157              (lambda (x)
 158                ; we're resuming a continuation
 159                (resume-continuation (cdr x) query)))
 160
 161             ((and query (assoc "submit" query))
 162              =>
 163              (lambda (x)
 164                ; we're starting the calculator
 165                (let* ((x (assoc "store_cont_on_server" query))
 166                       (on-server? (and x (string=? (cdr x) "yes"))))
 167                  (parameterize ((store-cont-on-server? on-server?))
 168                    (calculator-start)))))
 169
 170             (else
 171              (reply-html
 172               (<html>
 173                (<head> (<title> "Error"))
 174                (<body>
 175                 (<h1> "Something's wrong with the request...")))))))))
 176
 177 (table-set! page-generators "/calculator" page-calculator)
 178
 179 ; BUG: parameters lose their identity when serialized/deserialized so
 180 ; we can't store this information in a parameter.
 181 (define store-cont-on-server? (make-parameter #f))
 182
 183 (define calculator-start
 184   (lambda ()
 185     (let ((new-number
 186            (show-sum-and-obtain-number
 187             '()
 188             first-number-embed)))
 189       (calculator-loop (list new-number)))))
 190
 191 (define calculator-loop
 192   (lambda (numbers-previously-entered)
 193     (let ((new-number
 194            (show-sum-and-obtain-number
 195             numbers-previously-entered
 196             plain-embed)))
 197       (calculator-loop (append numbers-previously-entered
 198                                (list new-number))))))
 199
 200 (define show-sum-and-obtain-number
 201   (lambda (numbers-previously-entered embed)
 202     (let ((sum (apply + numbers-previously-entered)))
 203       (obtain-number
 204        (lambda (stuff)
 205          (embed
 206           (<table>
 207            (if (null? numbers-previously-entered)
 208                '()
 209                (list
 210                 (map (lambda (x)
 211                        (<tr> (<td>)
 212                              (<td> align: 'right x)))
 213                      numbers-previously-entered)
 214                 (<tr> (<td>)
 215                       (<td> align: 'right "---------------------"))
 216                 (<tr> (<td> "TOTAL:")
 217                       (<td> align: 'right bgcolor: "yellow" sum))))
 218            (<tr> (<td>)
 219                  (<td> stuff)))))))))
 220
 221 (define title-embed
 222   (lambda (stuff)
 223     (<html>
 224      (<head> (<title> "Web-continuation example"))
 225      (<body>
 226       (<h1> "Web-continuation example")
 227       (<p> "This page implements a simple calculator that adds the "
 228            "numbers that are entered by the user.")
 229       (<p> "You can use the " (<strong> "back") " button to undo the "
 230            "additions.  You can also clone the window and copy "
 231            "the URL to a different browser to start an independent "
 232             " branch of calculation.")
 233       (<p> "The web-server can be run interpreted or compiled.  It is "
 234            "much more efficient to use a compiled web-server because "
 235            "the continuations in the HTML file sent back to the browser "
 236            "will be much more compact.")
 237       (<p> "Please indicate if you want the continuation to be stored "
 238            "on the web browser or on the web server.  It is more "
 239            "efficient to store the continuation on the server but it "
 240            "introduces the problem of web-continuation garbage-collection "
 241            "(each continuation will be saved as a file on the server's file "
 242            "system; the issue is: when can these files be deleted?)")
 243       stuff))))
 244
 245 (define first-number-embed
 246   (lambda (stuff)
 247     (<html>
 248      (<head> (<title> "Web-continuation example"))
 249      (<body>
 250       (<h1> "Web-continuation example")
 251       (<p> "Enter the first number here: " stuff)))))
 252
 253 (define plain-embed
 254   (lambda (stuff)
 255     (<html>
 256      (<head> (<title> "Web-continuation example"))
 257      (<body>
 258       (<h1> "Web-continuation example")
 259       stuff))))
 260
 261 (define form-method "GET") ; can be "GET" or "POST"
 262
 263 (define obtain-number
 264   (lambda (embed)
 265     (let ((number-str
 266            (obtain
 267             "number"
 268             (lambda (cont)
 269               (embed
 270                (<form>
 271                 action: "/calculator"
 272                 method: form-method
 273                 (<input> type: 'hidden
 274                          name: "cont"
 275                          value: cont)
 276                 (<input> type: 'text name: "number")
 277                 (<input> type: 'submit
 278                          name: "submit"
 279                          value: "ADD")))))))
 280       (or (string->number number-str)
 281           (obtain-number embed)))))
 282
 283 (define obtain-store-cont-on-server
 284   (lambda (embed)
 285     (obtain
 286      "store_cont_on_server"
 287      (lambda (cont) ; continuation is ignored
 288        (embed
 289         (<form>
 290          action: "/calculator"
 291          method: form-method
 292          (<input> type: 'checkbox
 293                   name: "store_cont_on_server"
 294                   value: "yes"
 295                   "Store continuation on server")
 296          (<input> type: 'submit
 297                   name: "submit"
 298                   value: "\"START CALCULATOR\"")))))))
 299
 300 (define obtain
 301   (lambda (name embed)
 302     (let ((query
 303            (capture-continuation
 304             (lambda (cont)
 305               (reply-html (embed cont))
 306               (thread-terminate! (current-thread))))))
 307       (cdr (assoc name query)))))
 308
 309 (define capture-continuation
 310   (lambda (receiver)
 311     (call/cc
 312      (lambda (k)
 313        (let* ((k-str
 314                (u8vector->base64-string (object->u8vector k)))
 315               (cont
 316                (if (store-cont-on-server?)
 317                    (let loop () ; find a unique filename
 318                      (let* ((rn (random-integer (expt 2 64)))
 319                             (fn (string-append "_cont"
 320                                                (number->string rn 16))))
 321                        (if (file-exists? fn)
 322                            (loop)
 323                            (begin
 324                              (with-output-to-file fn
 325                                (lambda ()
 326                                  (display k-str)))
 327                              fn))))
 328                    k-str)))
 329          (receiver cont))))))
 330
 331 (define resume-continuation
 332   (lambda (cont val)
 333     (let* ((k-str
 334             (if (and (> (string-length cont) 0)
 335                      (char=? (string-ref cont 0) #\_))
 336                 (with-input-from-file cont read-line)
 337                 cont))
 338            (k
 339             (u8vector->object (base64-string->u8vector k-str))))
 340       (k val))))
 341
 342 ;==============================================================================
 343
 344 ; Web-IDE page.
 345
 346 (define page-web-ide
 347   (lambda ()
 348     (reply-html
 349      (<html>
 350       (<head>
 351        (<title> "Web-IDE page")
 352        (<style> web-ide-style)
 353        (<script> web-ide-script))
 354       (<body>
 355        (<p> "This example is not complete"))))))
 356
 357 (table-set! page-generators "/web-ide" page-web-ide)
 358
 359 (define web-ide-style #<<EOF
 360
 361 web ide style
 362
 363 EOF
 364 )
 365
 366 (define web-ide-script #<<EOF
 367
 368 web ide script
 369
 370 EOF
 371 )
 372
 373 ;==============================================================================
 374
 375 ; Web-server termination.
 376
 377 (define page-terminate-server
 378   (lambda ()
 379     (exit)))
 380
 381 (table-set! page-generators "/terminate-server" page-terminate-server)
 382
 383 ;==============================================================================