;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; 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 . (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) (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) (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 exception-handler (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 write-response-exception-handler (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) ;; 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 () (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 (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)) "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 exception-handler write-response-exception-handler connection-idle-timeout)) #:parallel? #t) (loop)))))) (make-web-server socket (vector-ref (getsockname socket) 2))) ; Not sure what this structure is