module/web/server.scm

   1 ;;; Web server
   2
   3 ;; Copyright (C)  2010 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18 ;; 02110-1301 USA
  19
  20 ;;; Commentary:
  21 ;;;
  22 ;;; (web server) is a generic web server interface, along with a main
  23 ;;; loop implementation for web servers controlled by Guile.
  24 ;;;
  25 ;;; The lowest layer is the <server-impl> object, which defines a set of
  26 ;;; hooks to open a server, read a request from a client, write a
  27 ;;; response to a client, and close a server.  These hooks -- open,
  28 ;;; read, write, and close, respectively -- are bound together in a
  29 ;;; <server-impl> object.  Procedures in this module take a
  30 ;;; <server-impl> object, if needed.
  31 ;;;
  32 ;;; A <server-impl> may also be looked up by name.  If you pass the
  33 ;;; `http' symbol to `run-server', Guile looks for a variable named
  34 ;;; `http' in the `(web server http)' module, which should be bound to a
  35 ;;; <server-impl> object.  Such a binding is made by instantiation of
  36 ;;; the `define-server-impl' syntax.  In this way the run-server loop can
  37 ;;; automatically load other backends if available.
  38 ;;;
  39 ;;; The life cycle of a server goes as follows:
  40 ;;;
  41 ;;;   * The `open' hook is called, to open the server. `open' takes 0 or
  42 ;;;     more arguments, depending on the backend, and returns an opaque
  43 ;;;     server socket object, or signals an error.
  44 ;;;
  45 ;;;   * The `read' hook is called, to read a request from a new client.
  46 ;;;     The `read' hook takes two arguments: the server socket, and a
  47 ;;;     list of keep-alive clients.  It should return four values:  the
  48 ;;;     new list of keep-alive clients, an opaque client socket, the
  49 ;;;     request, and the request body. The request should be a
  50 ;;;     `<request>' object, from `(web request)'.  The body should be a
  51 ;;;     string or a bytevector, or `#f' if there is no body.
  52 ;;;
  53 ;;;     The keep-alive list is used when selecting a new request.  You
  54 ;;;     can either serve an old client or serve a new client; and some
  55 ;;;     old clients might close their connections while you are waiting.
  56 ;;;     The `read' hook returns a new keep-alive set to account for old
  57 ;;;     clients going away, and for read errors on old clients.
  58 ;;;
  59 ;;;     If the read failed, the `read' hook may return #f for the client
  60 ;;;     socket, request, and body.
  61 ;;;
  62 ;;;   * A user-provided handler procedure is called, with the request
  63 ;;;     and body as its arguments.  The handler should return two
  64 ;;;     values: the response, as a `<response>' record from `(web
  65 ;;;     response)', and the response body as a string, bytevector, or
  66 ;;;     `#f' if not present.  We also allow the reponse to be simply an
  67 ;;;     alist of headers, in which case a default response object is
  68 ;;;     constructed with those headers.
  69 ;;;
  70 ;;;   * The `write' hook is called with three arguments: the client
  71 ;;;     socket, the response, and the body.  The `write' hook may return
  72 ;;;     #f to indicate that the connection was closed.  If `write'
  73 ;;;     returns a true value, it will be consed onto the keep-alive
  74 ;;;     list.
  75 ;;;
  76 ;;;   * At this point the request handling is complete. For a loop, we
  77 ;;;     loop back with the new keep-alive list, and try to read a new
  78 ;;;     request.
  79 ;;;
  80 ;;;   * If the user interrupts the loop, the `close' hook is called on
  81 ;;;     the server socket.
  82 ;;;
  83 ;;; Code:
  84
  85 (define-module (web server)
  86   #:use-module (srfi srfi-9)
  87   #:use-module (rnrs bytevectors)
  88   #:use-module (web request)
  89   #:use-module (web response)
  90   #:use-module (system repl error-handling)
  91   #:use-module (ice-9 control)
  92   #:export (define-server-impl
  93             lookup-server-impl
  94             open-server
  95             read-client
  96             handle-request
  97             sanitize-response
  98             write-client
  99             close-server
 100             serve-one-client
 101             run-server))
 102
 103 (define-record-type server-impl
 104   (make-server-impl name open read write close)
 105   server-impl?
 106   (name server-impl-name)
 107   (open server-impl-open)
 108   (read server-impl-read)
 109   (write server-impl-write)
 110   (close server-impl-close))
 111
 112 (define-syntax define-server-impl
 113   (syntax-rules ()
 114     ((_ name open read write close)
 115      (define name
 116        (make-server-impl 'name open read write close)))))
 117
 118 (define (lookup-server-impl impl)
 119   (cond
 120    ((server-impl? impl) impl)
 121    ((symbol? impl)
 122     (let ((impl (module-ref (resolve-module `(web server ,impl)) impl)))
 123       (if (server-impl? impl)
 124           impl
 125           (error "expected a server impl in module" `(web server ,impl)))))
 126    (else
 127     (error "expected a server-impl or a symbol" impl))))
 128
 129 ;; -> server
 130 (define (open-server impl open-params)
 131   (apply (server-impl-open impl) open-params))
 132
 133 ;; -> (keep-alive client request body | keep-alive #f #f #f)
 134 (define (read-client impl server keep-alive)
 135   (call-with-error-handling
 136    (lambda ()
 137      ((server-impl-read impl) server keep-alive))
 138    #:pass-keys '(quit interrupt)
 139    #:on-error (if (batch-mode?) 'pass 'debug)
 140    #:post-error
 141    (lambda (k . args)
 142      (warn "Error while accepting client" k args)
 143      (values keep-alive #f #f #f #f))))
 144
 145 ;; -> response body state ...
 146 (define (handle-request handler request body . state)
 147   (call-with-error-handling
 148    (lambda ()
 149      (with-stack-and-prompt
 150       (lambda ()
 151         (apply handler request body state))))
 152    #:pass-keys '(quit interrupt)
 153    #:on-error (if (batch-mode?) 'pass 'debug)
 154    #:post-error
 155    (lambda (k . args)
 156      (warn "Error handling request" k args)
 157      (apply values (build-response #:code 500) #f state))))
 158
 159 ;; -> response body
 160 (define (sanitize-response request response body)
 161   (values response body))
 162
 163 ;; -> (#f | client)
 164 (define (write-client impl server client response body)
 165   (call-with-error-handling
 166    (lambda ()
 167      ((server-impl-write impl) server client response body))
 168    #:pass-keys '(quit interrupt)
 169    #:on-error (if (batch-mode?) 'pass 'debug)
 170    #:post-error
 171    (lambda (k . args)
 172      (warn "Error while writing response" k args)
 173      #f)))
 174
 175 ;; -> unspecified values
 176 (define (close-server impl server)
 177   ((server-impl-close impl) server))
 178
 179 (define call-with-sigint
 180   (if (not (provided? 'posix))
 181       (lambda (thunk handler-thunk) (thunk))
 182       (lambda (thunk handler-thunk)
 183         (let ((handler #f))
 184           (catch 'interrupt
 185             (lambda ()
 186               (dynamic-wind
 187                 (lambda ()
 188                   (set! handler
 189                         (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
 190                 thunk
 191                 (lambda ()
 192                   (if handler
 193                       ;; restore Scheme handler, SIG_IGN or SIG_DFL.
 194                       (sigaction SIGINT (car handler) (cdr handler))
 195                       ;; restore original C handler.
 196                       (sigaction SIGINT #f)))))
 197             (lambda (k . _) (handler-thunk)))))))
 198
 199 (define (with-stack-and-prompt thunk)
 200   (call-with-prompt (default-prompt-tag)
 201                     (lambda () (start-stack #t (thunk)))
 202                     (lambda (k proc)
 203                       (with-stack-and-prompt (lambda () (proc k))))))
 204
 205 (define (and-cons x xs)
 206   (if x (cons x xs) xs))
 207
 208 ;; -> new keep-alive new-state
 209 (define (serve-one-client handler impl server keep-alive state)
 210   (call-with-values
 211       (lambda ()
 212         (read-client impl server keep-alive))
 213     (lambda (keep-alive client request body)
 214       (if client
 215           (call-with-values
 216               (lambda ()
 217                 (apply handle-request handler request body state))
 218             (lambda (response body . state)
 219               (call-with-values (lambda ()
 220                                   (sanitize-response request response body))
 221                 (lambda (response body)
 222                   (values
 223                    (and-cons (write-client impl server client response body)
 224                              keep-alive)
 225                    state)))))
 226           (values keep-alive state)))))
 227
 228 (define* (run-server handler #:optional (impl 'http) (open-params '())
 229                      . state)
 230   (let* ((impl (lookup-server-impl impl))
 231          (server (open-server impl open-params)))
 232     (call-with-sigint
 233      (lambda ()
 234        (let lp ((keep-alive '()) (state state))
 235          (call-with-values
 236              (lambda ()
 237                (serve-one-client handler impl server keep-alive state))
 238            (lambda (new-keep-alive new-state)
 239              (lp new-keep-alive new-state)))))
 240      (lambda ()
 241        (close-server impl server)
 242        (values)))))