module/web/server.scm

   1 ;;; Web server
   2
   3 ;; Copyright (C)  2010, 2011, 2012, 2013 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 one arguments, the server socket.  It
  47 ;;;     should return three values: an opaque client socket, the
  48 ;;;     request, and the request body. The request should be a
  49 ;;;     `<request>' object, from `(web request)'.  The body should be a
  50 ;;;     string or a bytevector, or `#f' if there is no body.
  51 ;;;
  52 ;;;     If the read failed, the `read' hook may return #f for the client
  53 ;;;     socket, request, and body.
  54 ;;;
  55 ;;;   * A user-provided handler procedure is called, with the request
  56 ;;;     and body as its arguments.  The handler should return two
  57 ;;;     values: the response, as a `<response>' record from `(web
  58 ;;;     response)', and the response body as a string, bytevector, or
  59 ;;;     `#f' if not present.  We also allow the reponse to be simply an
  60 ;;;     alist of headers, in which case a default response object is
  61 ;;;     constructed with those headers.
  62 ;;;
  63 ;;;   * The `write' hook is called with three arguments: the client
  64 ;;;     socket, the response, and the body.  The `write' hook returns no
  65 ;;;     values.
  66 ;;;
  67 ;;;   * At this point the request handling is complete. For a loop, we
  68 ;;;     loop back and try to read a new request.
  69 ;;;
  70 ;;;   * If the user interrupts the loop, the `close' hook is called on
  71 ;;;     the server socket.
  72 ;;;
  73 ;;; Code:
  74
  75 (define-module (web server)
  76   #:use-module (srfi srfi-9)
  77   #:use-module (rnrs bytevectors)
  78   #:use-module (ice-9 binary-ports)
  79   #:use-module (web request)
  80   #:use-module (web response)
  81   #:use-module (system repl error-handling)
  82   #:use-module (ice-9 control)
  83   #:use-module (ice-9 iconv)
  84   #:export (define-server-impl
  85             lookup-server-impl
  86             open-server
  87             read-client
  88             handle-request
  89             sanitize-response
  90             write-client
  91             close-server
  92             serve-one-client
  93             run-server))
  94
  95 (define *timer* (gettimeofday))
  96 (define (print-elapsed who)
  97   (let ((t (gettimeofday)))
  98     (pk who (+ (* (- (car t) (car *timer*)) 1000000)
  99                (- (cdr t) (cdr *timer*))))
 100     (set! *timer* t)))
 101
 102 (eval-when (expand)
 103   (define *time-debug?* #f))
 104
 105 (define-syntax debug-elapsed
 106   (lambda (x)
 107     (syntax-case x ()
 108       ((_ who)
 109        (if *time-debug?*
 110            #'(print-elapsed who)
 111            #'*unspecified*)))))
 112
 113 (define-record-type server-impl
 114   (make-server-impl name open read write close)
 115   server-impl?
 116   (name server-impl-name)
 117   (open server-impl-open)
 118   (read server-impl-read)
 119   (write server-impl-write)
 120   (close server-impl-close))
 121
 122 (define-syntax-rule (define-server-impl name open read write close)
 123   (define name
 124     (make-server-impl 'name open read write close)))
 125
 126 (define (lookup-server-impl impl)
 127   "Look up a server implementation.  If IMPL is a server
 128 implementation already, it is returned directly.  If it is a symbol, the
 129 binding named IMPL in the ‘(web server IMPL)’ module is
 130 looked up.  Otherwise an error is signaled.
 131
 132 Currently a server implementation is a somewhat opaque type, useful only
 133 for passing to other procedures in this module, like
 134 ‘read-client’."
 135   (cond
 136    ((server-impl? impl) impl)
 137    ((symbol? impl)
 138     (let ((impl (module-ref (resolve-module `(web server ,impl)) impl)))
 139       (if (server-impl? impl)
 140           impl
 141           (error "expected a server impl in module" `(web server ,impl)))))
 142    (else
 143     (error "expected a server-impl or a symbol" impl))))
 144
 145 ;; -> server
 146 (define (open-server impl open-params)
 147   "Open a server for the given implementation.  Return one value, the
 148 new server object.  The implementation's ‘open’ procedure is
 149 applied to OPEN-PARAMS, which should be a list."
 150   (apply (server-impl-open impl) open-params))
 151
 152 ;; -> (client request body | #f #f #f)
 153 (define (read-client impl server)
 154   "Read a new client from SERVER, by applying the implementation's
 155 ‘read’ procedure to the server.  If successful, return three
 156 values: an object corresponding to the client, a request object, and the
 157 request body.  If any exception occurs, return ‘#f’ for all three
 158 values."
 159   (call-with-error-handling
 160    (lambda ()
 161      ((server-impl-read impl) server))
 162    #:pass-keys '(quit interrupt)
 163    #:on-error (if (batch-mode?) 'backtrace 'debug)
 164    #:post-error (lambda _ (values #f #f #f))))
 165
 166 (define (extend-response r k v . additional)
 167   (define (extend-alist alist k v)
 168     (let ((pair (assq k alist)))
 169       (acons k v (if pair (delq pair alist) alist))))
 170   (let ((r (build-response #:version (response-version r)
 171                            #:code (response-code r)
 172                            #:headers
 173                            (extend-alist (response-headers r) k v)
 174                            #:port (response-port r))))
 175     (if (null? additional)
 176         r
 177         (apply extend-response r additional))))
 178
 179 ;; -> response body
 180 (define (sanitize-response request response body)
 181   "\"Sanitize\" the given response and body, making them appropriate for
 182 the given request.
 183
 184 As a convenience to web handler authors, RESPONSE may be given as
 185 an alist of headers, in which case it is used to construct a default
 186 response.  Ensures that the response version corresponds to the request
 187 version.  If BODY is a string, encodes the string to a bytevector,
 188 in an encoding appropriate for RESPONSE.  Adds a
 189 ‘content-length’ and ‘content-type’ header, as necessary.
 190
 191 If BODY is a procedure, it is called with a port as an argument,
 192 and the output collected as a bytevector.  In the future we might try to
 193 instead use a compressing, chunk-encoded port, and call this procedure
 194 later, in the write-client procedure.  Authors are advised not to rely
 195 on the procedure being called at any particular time."
 196   (cond
 197    ((list? response)
 198     (sanitize-response request
 199                        (build-response #:version (request-version request)
 200                                        #:headers response)
 201                        body))
 202    ((not (equal? (request-version request) (response-version response)))
 203     (sanitize-response request
 204                        (adapt-response-version response
 205                                                (request-version request))
 206                        body))
 207    ((not body)
 208     (values response #vu8()))
 209    ((string? body)
 210     (let* ((type (response-content-type response
 211                                         '(text/plain)))
 212            (declared-charset (assq-ref (cdr type) 'charset))
 213            (charset (or declared-charset "utf-8")))
 214       (sanitize-response
 215        request
 216        (if declared-charset
 217            response
 218            (extend-response response 'content-type
 219                             `(,@type (charset . ,charset))))
 220        (string->bytevector body charset))))
 221    ((procedure? body)
 222     (let* ((type (response-content-type response
 223                                         '(text/plain)))
 224            (declared-charset (assq-ref (cdr type) 'charset))
 225            (charset (or declared-charset "utf-8")))
 226       (sanitize-response
 227        request
 228        (if declared-charset
 229            response
 230            (extend-response response 'content-type
 231                             `(,@type (charset . ,charset))))
 232        (call-with-encoded-output-string charset body))))
 233    ((not (bytevector? body))
 234     (error "unexpected body type"))
 235    ((and (response-must-not-include-body? response)
 236          body
 237          (not (zero? (bytevector-length body))))
 238     (error "response with this status code must not include body" response))
 239    (else
 240     ;; check length; assert type; add other required fields?
 241     (values (let ((rlen (response-content-length response))
 242                   (blen (bytevector-length body)))
 243               (cond
 244                (rlen (if (= rlen blen)
 245                          response
 246                          (error "bad content-length" rlen blen)))
 247                ((zero? blen) response)
 248                (else (extend-response response 'content-length blen))))
 249             (if (eq? (request-method request) 'HEAD)
 250                 ;; Responses to HEAD requests must not include bodies.
 251                 ;; We could raise an error here, but it seems more
 252                 ;; appropriate to just do something sensible.
 253                 #f
 254                 body)))))
 255
 256 ;; -> response body state
 257 (define (handle-request handler request body state)
 258   "Handle a given request, returning the response and body.
 259
 260 The response and response body are produced by calling the given
 261 HANDLER with REQUEST and BODY as arguments.
 262
 263 The elements of STATE are also passed to HANDLER as
 264 arguments, and may be returned as additional values.  The new
 265 STATE, collected from the HANDLER's return values, is then
 266 returned as a list.  The idea is that a server loop receives a handler
 267 from the user, along with whatever state values the user is interested
 268 in, allowing the user's handler to explicitly manage its state."
 269   (call-with-error-handling
 270    (lambda ()
 271      (call-with-values (lambda ()
 272                          (with-stack-and-prompt
 273                           (lambda ()
 274                             (apply handler request body state))))
 275        (lambda (response body . state)
 276          (call-with-values (lambda ()
 277                              (debug-elapsed 'handler)
 278                              (sanitize-response request response body))
 279            (lambda (response body)
 280              (debug-elapsed 'sanitize)
 281              (values response body state))))))
 282    #:pass-keys '(quit interrupt)
 283    #:on-error (if (batch-mode?) 'backtrace 'debug)
 284    #:post-error (lambda _
 285                   (values (build-response #:code 500) #f state))))
 286
 287 ;; -> unspecified values
 288 (define (write-client impl server client response body)
 289   "Write an HTTP response and body to CLIENT.  If the server and
 290 client support persistent connections, it is the implementation's
 291 responsibility to keep track of the client thereafter, presumably by
 292 attaching it to the SERVER argument somehow."
 293   (call-with-error-handling
 294    (lambda ()
 295      ((server-impl-write impl) server client response body))
 296    #:pass-keys '(quit interrupt)
 297    #:on-error (if (batch-mode?) 'backtrace 'debug)
 298    #:post-error (lambda _ (values))))
 299
 300 ;; -> unspecified values
 301 (define (close-server impl server)
 302   "Release resources allocated by a previous invocation of
 303 ‘open-server’."
 304   ((server-impl-close impl) server))
 305
 306 (define call-with-sigint
 307   (if (not (provided? 'posix))
 308       (lambda (thunk handler-thunk) (thunk))
 309       (lambda (thunk handler-thunk)
 310         (let ((handler #f))
 311           (catch 'interrupt
 312             (lambda ()
 313               (dynamic-wind
 314                 (lambda ()
 315                   (set! handler
 316                         (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
 317                 thunk
 318                 (lambda ()
 319                   (if handler
 320                       ;; restore Scheme handler, SIG_IGN or SIG_DFL.
 321                       (sigaction SIGINT (car handler) (cdr handler))
 322                       ;; restore original C handler.
 323                       (sigaction SIGINT #f)))))
 324             (lambda (k . _) (handler-thunk)))))))
 325
 326 (define (with-stack-and-prompt thunk)
 327   (call-with-prompt (default-prompt-tag)
 328                     (lambda () (start-stack #t (thunk)))
 329                     (lambda (k proc)
 330                       (with-stack-and-prompt (lambda () (proc k))))))
 331
 332 ;; -> new-state
 333 (define (serve-one-client handler impl server state)
 334   "Read one request from SERVER, call HANDLER on the request
 335 and body, and write the response to the client.  Return the new state
 336 produced by the handler procedure."
 337   (debug-elapsed 'serve-again)
 338   (call-with-values
 339       (lambda ()
 340         (read-client impl server))
 341     (lambda (client request body)
 342       (debug-elapsed 'read-client)
 343       (if client
 344           (call-with-values
 345               (lambda ()
 346                 (handle-request handler request body state))
 347             (lambda (response body state)
 348               (debug-elapsed 'handle-request)
 349               (write-client impl server client response body)
 350               (debug-elapsed 'write-client)
 351               state))
 352           state))))
 353
 354 (define* (run-server handler #:optional (impl 'http) (open-params '())
 355                      . state)
 356   "Run Guile's built-in web server.
 357
 358 HANDLER should be a procedure that takes two or more arguments,
 359 the HTTP request and request body, and returns two or more values, the
 360 response and response body.
 361
 362 For example, here is a simple \"Hello, World!\" server:
 363
 364 @example
 365  (define (handler request body)
 366    (values '((content-type . (text/plain)))
 367            \"Hello, World!\"))
 368  (run-server handler)
 369 @end example
 370
 371 The response and body will be run through ‘sanitize-response’
 372 before sending back to the client.
 373
 374 Additional arguments to HANDLER are taken from
 375 STATE.  Additional return values are accumulated into a new
 376 STATE, which will be used for subsequent requests.  In this way a
 377 handler can explicitly manage its state.
 378
 379 The default server implementation is ‘http’, which accepts
 380 OPEN-PARAMS like ‘(#:port 8081)’, among others.  See \"Web
 381 Server\" in the manual, for more information."
 382   (let* ((impl (lookup-server-impl impl))
 383          (server (open-server impl open-params)))
 384     (call-with-sigint
 385      (lambda ()
 386        (let lp ((state state))
 387          (lp (serve-one-client handler impl server state))))
 388      (lambda ()
 389        (close-server impl server)
 390        (values)))))