Christopher Baines
e1858dfff5
This turned out not to be useful, since I wanted to handle exceptions happening in the exception handler, so it didn't really help in the end to allow customising it.
539 lines
20 KiB
Scheme
539 lines
20 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 (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
|
||
|
||
&request-body-ended-prematurely
|
||
request-body-ended-prematurely-error?
|
||
|
||
request-body-port/knots
|
||
read-request-body/knots
|
||
|
||
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))
|
||
"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))
|
||
(setvbuf ret 'block buffering)
|
||
ret)
|
||
|
||
(define* (make-delimited-input-port port len fail
|
||
#:key (keep-alive? #t))
|
||
"Return an input port that reads from PORT, and makes sure that
|
||
exactly LEN bytes are available from PORT. Closing the returned port
|
||
closes PORT, unless KEEP-ALIVE? is true."
|
||
(define bytes-read 0)
|
||
|
||
(define (read! bv start count)
|
||
(let ((count (min count (- len bytes-read))))
|
||
(let loop ((ret (get-bytevector-n! port bv start count)))
|
||
(cond ((eof-object? ret)
|
||
(if (= bytes-read len)
|
||
0 ; EOF
|
||
(fail bytes-read)))
|
||
((and (zero? ret) (> count 0))
|
||
;; Do not return zero since zero means EOF, so try again.
|
||
(loop (get-bytevector-n! port bv start count)))
|
||
(else
|
||
(set! bytes-read (+ bytes-read ret))
|
||
ret)))))
|
||
|
||
(define close
|
||
(and (not keep-alive?)
|
||
(lambda ()
|
||
(close-port port))))
|
||
|
||
(make-custom-binary-input-port "delimited input port" read! #f #f close))
|
||
|
||
;; Chunked Responses
|
||
(define &request-body-ended-prematurely
|
||
(make-exception-type '&request-body-ended-prematurely
|
||
&external-error
|
||
'(bytes-read)))
|
||
|
||
(define make-request-body-ended-prematurely-error
|
||
(record-constructor &request-body-ended-prematurely))
|
||
|
||
(define request-body-ended-prematurely-error?
|
||
(record-predicate &request-body-ended-prematurely))
|
||
|
||
(define (request-body-port/knots r)
|
||
(cond
|
||
((member '(chunked) (request-transfer-encoding r))
|
||
(make-chunked-input-port (request-port r)
|
||
#:keep-alive? #t))
|
||
(else
|
||
(let ((content-length
|
||
(request-content-length r)))
|
||
(make-delimited-input-port
|
||
(request-port r)
|
||
content-length
|
||
(lambda (bytes-read)
|
||
(raise-exception
|
||
(make-request-body-ended-prematurely-error bytes-read))))))))
|
||
|
||
(define (read-request-body/knots r)
|
||
(cond
|
||
((member '(chunked) (request-transfer-encoding r))
|
||
(get-bytevector-all
|
||
(request-body-port/knots r)))
|
||
(else
|
||
(let ((content-length
|
||
(request-content-length r)))
|
||
(if content-length
|
||
(get-bytevector-n
|
||
(request-body-port/knots r)
|
||
content-length)
|
||
#f)))))
|
||
|
||
(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))))
|
||
|
||
(define (response-maybe-add-connection-header-value request response)
|
||
(if (memq 'close (response-connection response))
|
||
;; Nothing to do
|
||
response
|
||
(let* ((v (request-version request))
|
||
(add-close-header?
|
||
(case (car v)
|
||
((1)
|
||
(case (cdr v)
|
||
((1) (memq 'close (request-connection request)))
|
||
((0) (not (memq 'keep-alive (request-connection request))))))
|
||
(else #t))))
|
||
(if add-close-header?
|
||
(extend-response response 'connection '(close))
|
||
(if (and (= 1 (car v))
|
||
(= 0 (cdr v)))
|
||
(extend-response response 'connection '(keep-alive))
|
||
response)))))
|
||
|
||
;; -> 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 (response-maybe-add-connection-header-value
|
||
request
|
||
(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)
|
||
(not (memq 'close (response-connection response))))
|
||
|
||
(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)
|
||
(if (and (exception-with-origin? exn)
|
||
(string=? (exception-origin exn)
|
||
"fport_write"))
|
||
(simple-format
|
||
(current-error-port)
|
||
"~A ~A: error replying to client\n"
|
||
(request-method request)
|
||
(uri-path (request-uri request)))
|
||
(simple-format
|
||
(current-error-port)
|
||
"knots web server: ~A ~A: exception replying to client: ~A\n"
|
||
(request-method request)
|
||
(uri-path (request-uri request))
|
||
exn))
|
||
|
||
;; Close the client port
|
||
#f)
|
||
|
||
(define (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)
|
||
(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)
|
||
(connection . (close))))
|
||
#vu8()))
|
||
(else
|
||
(call-with-escape-continuation
|
||
(lambda (return)
|
||
(with-exception-handler
|
||
(lambda (exn)
|
||
(call-with-values
|
||
(lambda ()
|
||
(exception-handler exn request))
|
||
(lambda (response body)
|
||
(call-with-values
|
||
(lambda ()
|
||
(sanitize-response request response body))
|
||
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 ((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))))
|
||
(set-port-encoding! body-port 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 (and (procedure? body)
|
||
(response-content-length response))
|
||
(set-port-encoding! client "ISO-8859-1"))
|
||
(keep-alive? response))
|
||
#f)))
|
||
#:unwind? #t))))
|
||
|
||
(define* (client-loop client 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 (exn)
|
||
(unless (and (exception-with-origin? exn)
|
||
(string=? (exception-origin exn)
|
||
"fport_read"))
|
||
(display "knots web-server, exception in client loop:\n"
|
||
(current-error-port))
|
||
(print-exception
|
||
(current-error-port)
|
||
#f
|
||
'%exception
|
||
(list exn)))
|
||
#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))))
|
||
#:unwind? #t)
|
||
(close-port client))
|
||
(else
|
||
(let ((keep-alive? (handle-request handler client
|
||
read-request-exception-handler
|
||
write-response-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))
|
||
(read-request-exception-handler
|
||
default-read-request-exception-handler)
|
||
(write-response-exception-handler
|
||
default-write-response-exception-handler)
|
||
(connection-idle-timeout #f)
|
||
(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
|
||
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
|