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 (ice-9 control)
  #: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 uri)
  #:use-module (web http)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (knots)
  #:use-module (knots timeout)
  #:use-module (knots non-blocking)
  #:export (run-knots-web-server

            make-chunked-output-port/knots

            default-exception-handler
            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* (make-chunked-output-port/knots port #:key (keep-alive? #f)
                                         (buffering 1200)
                                         (encoding "ISO-8859-1"))
  "Returns a new port which translates non-encoded data into a HTTP
chunked transfer encoded data and writes this to PORT. Data written to
this port is buffered until the port is flushed, at which point it is
all sent as one chunk.  The port will otherwise be flushed every
BUFFERING bytes, which defaults to 1200.  Take care to close the port
when done, as it will output the remaining data, and encode the final
zero chunk. When the port is closed it will also close PORT, unless
KEEP-ALIVE? is true."
  (define (write! bv start count)
    (put-string port (number->string count 16))
    (put-string port "\r\n")
    (put-bytevector port bv start count)
    (put-string port "\r\n")
    (force-output port)
    count)

  (define (close)
    (put-string port "0\r\n\r\n")
    (force-output port)
    (unless keep-alive?
      (close-port port)))

  (define ret
    (make-custom-binary-output-port "chunked http" write! #f #f close))
  (set-port-encoding! ret encoding)
  (setvbuf ret 'block buffering)
  ret)

(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-read-request-exception-handler exn)
  (display "While reading request:\n" (current-error-port))
  (print-exception
   (current-error-port)
   #f
   '%exception
   (list exn))

  #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)
  (let* ((error-string
          (call-with-output-string
            (lambda (port)
              (simple-format
               port
               "exception when processing: ~A ~A\n"
               (request-method request)
               (uri-path (request-uri request)))
              (print-backtrace-and-exception/knots
               exn
               #:port port)))))
    (display error-string
             (current-error-port)))

  (values (build-response #:code 500)
          ;; TODO Make this configurable
          (string->utf8
           "internal server error")))

(define (handle-request handler client
                        read-request-exception-handler
                        write-response-exception-handler
                        exception-handler)
  (let ((request
         (with-exception-handler
             read-request-exception-handler
           (lambda ()
             (read-request client))
           #:unwind? #t)))
    (let ((response
           body
           (cond
            ((not request)
             ;; Bad request.
             (values (build-response #:version '(1 . 0) #:code 400
                                     #:headers '((content-length . 0)))
                     #vu8()))
            (else
             (call-with-escape-continuation
              (lambda (return)
                (with-exception-handler
                    (lambda (exn)
                      (call-with-values
                          (lambda ()
                            (exception-handler exn request))
                        return))
                  (lambda ()
                    (start-stack
                     #t
                     (call-with-values
                         (lambda ()
                           (handler request))
                       (match-lambda*
                         ((response body)
                          (sanitize-response request response body))
                         (other
                          (raise-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)))))))))))))))
      (with-exception-handler
          (lambda (exn)
            (write-response-exception-handler exn request))
        (lambda ()
          (write-response response client)

          (let* ((change-client-port-encoding?
                 (and (procedure? body)
                      (not (response-content-length response))))
                (body-written?
                 (if (procedure? body)
                     (let* ((type (response-content-type response
                                                         '(text/plain)))
                            (declared-charset (assq-ref (cdr type) 'charset))
                            (charset (or declared-charset "ISO-8859-1"))
                            (body-port
                             (if (response-content-length response)
                                 client
                                 (make-chunked-output-port/knots
                                  client
                                  #:keep-alive? #t
                                  #:encoding charset))))
                       (when change-client-port-encoding?
                         (set-port-encoding! client charset))
                       (let ((body-written?
                              (with-exception-handler
                                  (lambda (exn)
                                    #f)
                                (lambda ()
                                  (with-exception-handler
                                      (lambda (exn)
                                        (print-backtrace-and-exception/knots exn)
                                        (raise-exception exn))
                                    (lambda ()
                                      (body body-port)))
                                  #t)
                                #:unwind? #t)))
                         (unless (response-content-length response)
                           (close-port body-port))
                         body-written?))
                     (begin
                       (put-bytevector client body)
                       #t))))
            (if body-written?
                (begin
                  (force-output client)
                  (when change-client-port-encoding?
                    (set-port-encoding! client "ISO-8859-1"))
                  (keep-alive? response))
                #f)))
        #:unwind? #t))))

(define* (client-loop client handler
                      exception-handler
                      read-request-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)
  (let loop ()
    (cond
     ((with-exception-handler
          (lambda _ #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)))))
      (close-port client))
     (else
      (let ((keep-alive? (handle-request handler client
                                         read-request-exception-handler
                                         write-response-exception-handler
                                         exception-handler)))
        (if keep-alive?
            (loop)
            (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)
                               (read-request-exception-handler
                                default-read-request-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
                                      read-request-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