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