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 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 (rnrs io 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 define-server-impl
 122   (syntax-rules ()
 123     ((_ 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   (cond
 129    ((server-impl? impl) impl)
 130    ((symbol? impl)
 131     (let ((impl (module-ref (resolve-module `(web server ,impl)) impl)))
 132       (if (server-impl? impl)
 133           impl
 134           (error "expected a server impl in module" `(web server ,impl)))))
 135    (else
 136     (error "expected a server-impl or a symbol" impl))))
 137
 138 ;; -> server
 139 (define (open-server impl open-params)
 140   (apply (server-impl-open impl) open-params))
 141
 142 ;; -> (client request body | #f #f #f)
 143 (define (read-client impl server)
 144   (call-with-error-handling
 145    (lambda ()
 146      ((server-impl-read impl) server))
 147    #:pass-keys '(quit interrupt)
 148    #:on-error (if (batch-mode?) 'pass 'debug)
 149    #:post-error
 150    (lambda (k . args)
 151      (warn "Error while accepting client" k args)
 152      (values #f #f #f))))
 153
 154 (define (call-with-encoded-output-string charset proc)
 155   (if (and (string-ci=? charset "utf-8") #f)
 156       ;; I don't know why, but this appears to be faster; at least for
 157       ;; examples/debug-sxml.scm (650 reqs/s versus 510 reqs/s).
 158       (string->utf8 (call-with-output-string proc))
 159       (call-with-values
 160           (lambda ()
 161             (open-bytevector-output-port))
 162         (lambda (port get-bytevector)
 163           (set-port-encoding! port charset)
 164           (proc port)
 165           (get-bytevector)))))
 166
 167 (define (encode-string str charset)
 168   (if (string-ci=? charset "utf-8")
 169       (string->utf8 str)
 170       (call-with-encoded-output-string charset
 171                                        (lambda (port)
 172                                          (display str port)))))
 173
 174 ;; -> response body
 175 (define (sanitize-response request response body)
 176   (cond
 177    ((list? response)
 178     (sanitize-response request
 179                        (build-response #:version (request-version request)
 180                                        #:headers response)
 181                        body))
 182    ((not (equal? (request-version request) (response-version response)))
 183     (sanitize-response request
 184                        (adapt-response-version response
 185                                                (request-version request))
 186                        body))
 187    ((not body)
 188     (values response #vu8()))
 189    ((string? body)
 190     (let* ((type (response-content-type response
 191                                         '("text/plain")))
 192            (declared-charset (assoc-ref (cdr type) "charset"))
 193            (charset (or declared-charset "utf-8")))
 194       (sanitize-response
 195        request
 196        (if declared-charset
 197            response
 198            (extend-response response 'content-type
 199                             `(,@type ("charset" . ,charset))))
 200        (encode-string body charset))))
 201    ((procedure? body)
 202     (let* ((type (response-content-type response
 203                                         '("text/plain")))
 204            (declared-charset (assoc-ref (cdr type) "charset"))
 205            (charset (or declared-charset "utf-8")))
 206       (sanitize-response
 207        request
 208        (if declared-charset
 209            response
 210            (extend-response response 'content-type
 211                             `(,@type ("charset" . ,charset))))
 212        (call-with-encoded-output-string charset body))))
 213    ((bytevector? body)
 214     ;; check length; assert type; add other required fields?
 215     (values (let ((rlen (response-content-length response))
 216                   (blen (bytevector-length body)))
 217               (cond
 218                (rlen (if (= rlen blen)
 219                          response
 220                          (error "bad content-length" rlen blen)))
 221                ((zero? blen) response)
 222                (else (extend-response response 'content-length blen))))
 223             body))
 224    (else
 225     (error "unexpected body type"))))
 226
 227 ;; -> response body state
 228 (define (handle-request handler request body state)
 229   (call-with-error-handling
 230    (lambda ()
 231      (call-with-values (lambda ()
 232                          (with-stack-and-prompt
 233                           (lambda ()
 234                             (apply handler request body state))))
 235        (lambda (response body . state)
 236          (call-with-values (lambda ()
 237                              (debug-elapsed 'handler)
 238                              (sanitize-response request response body))
 239            (lambda (response body)
 240              (debug-elapsed 'sanitize)
 241              (values response body state))))))
 242    #:pass-keys '(quit interrupt)
 243    #:on-error (if (batch-mode?) 'pass 'debug)
 244    #:post-error
 245    (lambda (k . args)
 246      (warn "Error handling request" k args)
 247      (values (build-response #:code 500) #f state))))
 248
 249 ;; -> unspecified values
 250 (define (write-client impl server client response body)
 251   (call-with-error-handling
 252    (lambda ()
 253      ((server-impl-write impl) server client response body))
 254    #:pass-keys '(quit interrupt)
 255    #:on-error (if (batch-mode?) 'pass 'debug)
 256    #:post-error
 257    (lambda (k . args)
 258      (warn "Error while writing response" k args)
 259      (values))))
 260
 261 ;; -> unspecified values
 262 (define (close-server impl server)
 263   ((server-impl-close impl) server))
 264
 265 (define call-with-sigint
 266   (if (not (provided? 'posix))
 267       (lambda (thunk handler-thunk) (thunk))
 268       (lambda (thunk handler-thunk)
 269         (let ((handler #f))
 270           (catch 'interrupt
 271             (lambda ()
 272               (dynamic-wind
 273                 (lambda ()
 274                   (set! handler
 275                         (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
 276                 thunk
 277                 (lambda ()
 278                   (if handler
 279                       ;; restore Scheme handler, SIG_IGN or SIG_DFL.
 280                       (sigaction SIGINT (car handler) (cdr handler))
 281                       ;; restore original C handler.
 282                       (sigaction SIGINT #f)))))
 283             (lambda (k . _) (handler-thunk)))))))
 284
 285 (define (with-stack-and-prompt thunk)
 286   (call-with-prompt (default-prompt-tag)
 287                     (lambda () (start-stack #t (thunk)))
 288                     (lambda (k proc)
 289                       (with-stack-and-prompt (lambda () (proc k))))))
 290
 291 ;; -> new-state
 292 (define (serve-one-client handler impl server state)
 293   (debug-elapsed 'serve-again)
 294   (call-with-values
 295       (lambda ()
 296         (read-client impl server))
 297     (lambda (client request body)
 298       (debug-elapsed 'read-client)
 299       (if client
 300           (call-with-values
 301               (lambda ()
 302                 (handle-request handler request body state))
 303             (lambda (response body state)
 304               (debug-elapsed 'handle-request)
 305               (write-client impl server client response body)
 306               (debug-elapsed 'write-client)
 307               state))
 308           state))))
 309
 310 (define* (run-server handler #:optional (impl 'http) (open-params '())
 311                      . state)
 312   (let* ((impl (lookup-server-impl impl))
 313          (server (open-server impl open-params)))
 314     (call-with-sigint
 315      (lambda ()
 316        (let lp ((state state))
 317          (lp (serve-one-client handler impl server state))))
 318      (lambda ()
 319        (close-server impl server)
 320        (values)))))