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 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 ((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 non-blocking)
  #:export (run-knots-web-server

            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)))
    (error "unexpected body type"))
   ((and (response-must-not-include-body? response)
         body
         ;; FIXME make this stricter: even an empty body should be prohibited.
         (not (zero? (bytevector-length body))))
    (error "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)
                ;; Responses to HEAD requests must not include bodies.
                ;; We could raise an error here, but it seems more
                ;; appropriate to just do something sensible.
                #f
                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 (handle-request handler client)
  (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
             (call-with-error-handling
              (lambda ()
                (call-with-values (lambda ()
                                    (with-stack-and-prompt
                                     (lambda ()
                                       (handler request))))
                  (lambda (response body)
                    (sanitize-response request response body))))
              #:on-error 'backtrace
              #:post-error (lambda _
                             (values (build-response #:code 500) #f)))))))
      (write-response response client)
      (when body
        (if (procedure? body)
            (if (response-content-length response)
                (body client)
                (let ((chunked-port
                       (make-chunked-output-port client
                                                 #:keep-alive? #t)))
                  (body chunked-port)
                  (close-port chunked-port)))
            (put-bytevector client body)))
      (force-output client)

      (keep-alive? response))))

(define (client-loop client handler)
  ;; 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 1024)
  (setsockopt client IPPROTO_TCP TCP_NODELAY 1)
  (with-throw-handler #t
    (lambda ()
      (let loop ()
        (cond
         ((catch #t
            (lambda () (eof-object? (lookahead-u8 client)))
            (lambda _ #t))
          (close-port client))
         (else
          (let ((keep-alive? (handle-request handler client)))
            (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)))
  "Run the fibers 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-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))
                       #:parallel? #t)
          (loop))))))

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