guile-knots/knots/web-server.scm

;;; Guile Knots
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;; Copyright (C)  2010-2013,2015,2017 Free Software Foundation, Inc.

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (knots web-server)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-71)
  #:use-module (fibers)
  #:use-module (fibers timers)
  #:use-module (fibers operations)
  #:use-module (fibers conditions)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module ((srfi srfi-9 gnu) #:select (set-field))
  #:use-module (system repl error-handling)
  #:use-module (web http)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (knots timeout)
  #:use-module (knots non-blocking)
  #:export (run-knots-web-server

            default-write-response-exception-handler

            web-server?
            web-server-socket
            web-server-port))

(define (make-default-socket family addr port)
  (let ((sock (socket PF_INET SOCK_STREAM 0)))
    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
    (fcntl sock F_SETFD FD_CLOEXEC)
    (bind sock family addr port)
    sock))

(define (extend-response r k v . additional)
  (define (extend-alist alist k v)
    (let ((pair (assq k alist)))
      (acons k v (if pair (delq pair alist) alist))))
  (let ((r (set-field r (response-headers)
                      (extend-alist (response-headers r) k v))))
    (if (null? additional)
        r
        (apply extend-response r additional))))

;; -> response body
(define (sanitize-response request response body)
  "\"Sanitize\" the given response and body, making them appropriate for
the given request.

As a convenience to web handler authors, RESPONSE may be given as
an alist of headers, in which case it is used to construct a default
response.  Ensures that the response version corresponds to the request
version.  If BODY is a string, encodes the string to a bytevector,
in an encoding appropriate for RESPONSE.  Adds a
‘content-length’ and ‘content-type’ header, as necessary.

If BODY is a procedure, it is called with a port as an argument,
and the output collected as a bytevector.  In the future we might try to
instead use a compressing, chunk-encoded port, and call this procedure
later, in the write-client procedure.  Authors are advised not to rely
on the procedure being called at any particular time."
  (cond
   ((list? response)
    (sanitize-response request
                       (build-response #:version (request-version request)
                                       #:headers response)
                       body))
   ((not (equal? (request-version request) (response-version response)))
    (sanitize-response request
                       (adapt-response-version response
                                               (request-version request))
                       body))
   ((not body)
    (values response #vu8()))
   ((string? body)
    (let* ((type (response-content-type response
                                        '(text/plain)))
           (declared-charset (assq-ref (cdr type) 'charset))
           (charset (or declared-charset "utf-8")))
      (sanitize-response
       request
       (if declared-charset
           response
           (extend-response response 'content-type
                            `(,@type (charset . ,charset))))
       (string->bytevector body charset))))
   ((not (or (bytevector? body)
             (procedure? body)))
    (raise-exception
     (make-exception-with-irritants
      (list (make-exception-with-message
             "unexpected body type")
            body))))
   ((and (response-must-not-include-body? response)
         body
         ;; FIXME make this stricter: even an empty body should be prohibited.
         (not (zero? (bytevector-length body))))
    (raise-exception
     (make-exception-with-irritants
      (list (make-exception-with-message
             "response with this status code must not include body")
            response))))
   (else
    ;; check length; assert type; add other required fields?
    (values (if (procedure? body)
                (if (response-content-length response)
                    response
                    (extend-response response
                                     'transfer-encoding
                                     '((chunked))))
                (let ((rlen (response-content-length response))
                      (blen (bytevector-length body)))
                  (cond
                   (rlen (if (= rlen blen)
                             response
                             (error "bad content-length" rlen blen)))
                   (else (extend-response response 'content-length blen)))))
            (if (eq? (request-method request) 'HEAD)
                (raise-exception
                 (make-exception-with-irritants
                  (list (make-exception-with-message
                         "unexpected body type")
                        body)))
                body)))))

(define (with-stack-and-prompt thunk)
  (call-with-prompt (default-prompt-tag)
                    (lambda () (start-stack #t (thunk)))
                    (lambda (k proc)
                      (with-stack-and-prompt (lambda () (proc k))))))

(define (keep-alive? response)
  (let ((v (response-version response)))
    (and (or (< (response-code response) 400)
             (= (response-code response) 404))
         (case (car v)
           ((1)
            (case (cdr v)
              ((1) (not (memq 'close (response-connection response))))
              ((0) (memq 'keep-alive (response-connection response)))))
           (else #f)))))

(define (default-write-response-exception-handler exn request)
  (simple-format
   (current-error-port)
   "knots web server: exception replying to client: ~A\n" exn)

  ;; Close the client port
  #f)

(define (default-exception-handler exn request)
  (values (build-response #:code 500)
          ;; TODO Make this configurable
          (string->utf8
           "internal server error")))

(define (handle-request handler client
                        write-response-exception-handler
                        exception-handler)
  (let ((request
         (catch #t
           (lambda ()
             (read-request client))
           (lambda (key . args)
             (display "While reading request:\n" (current-error-port))
             (print-exception (current-error-port) #f key args)
             #f))))
    (let ((response
           body
           (cond
            ((not request)
             ;; Bad request.
             (values (build-response #:version '(1 . 0) #:code 400
                                     #:headers '((content-length . 0)))
                     #vu8()))
            (else
             (with-exception-handler
                 (lambda (exn)
                   (exception-handler exn request))
               (lambda ()
                 (call-with-values (lambda ()
                                     (with-stack-and-prompt
                                      (lambda ()
                                        (with-throw-handler #t
                                          (lambda ()
                                            (handler request))
                                          (lambda (key . args)
                                            (let ((stack (make-stack #t)))
                                              (print-exception
                                               (current-error-port)
                                               (stack-ref stack 2)
                                               key
                                               args)
                                              (display-backtrace
                                               stack
                                               (current-error-port)
                                               2)))))))
                   (match-lambda*
                     ((response body)
                      (sanitize-response request response body))
                     (other
                      (let ((stack (make-stack #t))
                            (exception
                             (make-exception-with-irritants
                              (list (make-exception-with-message
                                     (simple-format
                                      #f
                                      "wrong number of values returned from handler, expecting 2, got ~A"
                                      (length other)))
                                    handler))))
                        (print-exception
                         (current-error-port)
                         (stack-ref stack 2)
                         '%exception
                         (list exception))
                        (raise-exception exception))))))
               #:unwind? #t)))))
      (with-exception-handler
          (lambda (exn)
            (write-response-exception-handler exn request))
        (lambda ()
          (write-response response client)

          (let ((body-written?
                 (if (procedure? body)
                     (if (response-content-length response)
                         (with-exception-handler
                             (lambda (exn)
                               #f)
                           (lambda ()
                             (with-stack-and-prompt
                              (lambda ()
                                (with-throw-handler #t
                                  (lambda ()
                                    (body client))
                                  (lambda (key . args)
                                    (let ((stack (make-stack #t)))
                                      (print-exception
                                       (current-error-port)
                                       (stack-ref stack 2)
                                       key
                                       args)
                                      (display-backtrace
                                       stack
                                       (current-error-port)
                                       2))))))
                             #t)
                           #:unwind? #t)
                         (let ((chunked-port
                                (make-chunked-output-port client
                                                          #:keep-alive? #t)))
                           (with-exception-handler
                               (lambda (exn)
                                 #f)
                             (lambda ()
                               (with-throw-handler #t
                                 (lambda ()
                                   (body chunked-port)
                                   (close-port chunked-port))
                                 (lambda (key . args)
                                   (let ((stack (make-stack #t)))
                                     (print-exception
                                      (current-error-port)
                                      (stack-ref stack 2)
                                      key
                                      args)
                                     (display-backtrace
                                      stack
                                      (current-error-port)
                                      2))))
                               #t)
                             #:unwind? #t)))
                     (begin
                       (put-bytevector client body)
                       #t))))
            (if body-written?
                (begin
                  (force-output client)
                  (keep-alive? response))
                #f)))
        #:unwind? #t))))

(define* (client-loop client handler
                      exception-handler
                      write-response-exception-handler
                      connection-idle-timeout
                      buffer-size)
  ;; Always disable Nagle's algorithm, as we handle buffering
  ;; ourselves; when we force-output, we really want the data to go
  ;; out.
  (setvbuf client 'block buffer-size)
  (setsockopt client IPPROTO_TCP TCP_NODELAY 1)
  (with-throw-handler #t
    (lambda ()
      (let loop ()
        (cond
         ((catch #t
            (lambda ()
              (or
               (if (eq? #f connection-idle-timeout)
                   #f
                   (perform-operation
                    (choice-operation (wrap-operation
                                       (wait-until-port-readable-operation client)
                                       (const #f))
                                      (wrap-operation
                                       (sleep-operation connection-idle-timeout)
                                       (const #t)))))
               (eof-object? (lookahead-u8 client))))
            (lambda _ #t))
          (close-port client))
         (else
          (let ((keep-alive? (handle-request handler client
                                             write-response-exception-handler
                                             exception-handler)))
            (if keep-alive?
                (loop)
                (close-port client)))))))
    (lambda (k . args)
      (close-port client))))

(define-record-type <web-server>
  (make-web-server socket port)
  web-server?
  (socket    web-server-socket)
  (port      web-server-port))

(define* (run-knots-web-server handler #:key
                               (host #f)
                               (family AF_INET)
                               (addr (if host
                                         (inet-pton family host)
                                         INADDR_LOOPBACK))
                               (port 8080)
                               (socket (make-default-socket family addr port))
                               (exception-handler
                                default-exception-handler)
                               (write-response-exception-handler
                                default-write-response-exception-handler)
                               (connection-idle-timeout 60)
                               (connection-buffer-size 1024))
  "Run the knots web server.

HANDLER should be a procedure that takes one argument, the HTTP
request and returns two values, the response and response body.

For example, here is a simple \"Hello, World!\" server:

@example
 (define (handler request)
   (let ((body (read-request-body request)))
     (values '((content-type . (text/plain)))
             \"Hello, World!\")))
 (run-knots-web-server handler)
@end example

The response and body will be run through ‘sanitize-response’
before sending back to the client."
  (non-blocking-port socket)
  ;; We use a large backlog by default.  If the server is suddenly hit
  ;; with a number of connections on a small backlog, clients won't
  ;; receive confirmation for their SYN, leading them to retry --
  ;; probably successfully, but with a large latency.
  (listen socket 1024)
  (sigaction SIGPIPE SIG_IGN)

  (spawn-fiber
   (lambda ()
     (let loop ()
       (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
         ((client . sockaddr)
          (spawn-fiber (lambda ()
                         (client-loop client handler
                                      exception-handler
                                      write-response-exception-handler
                                      connection-idle-timeout
                                      connection-buffer-size))
                       #:parallel? #t)
          (loop))))))

  (make-web-server socket
                   (vector-ref (getsockname socket)
                               2)))  ; Not sure what this structure is