module/web/server.scm

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