263 lines
10 KiB
Scheme
263 lines
10 KiB
Scheme
;;; 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
|