429 lines
17 KiB
Scheme
429 lines
17 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
|
||
|
||
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-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
|
||
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
|
||
(call-with-values
|
||
(lambda ()
|
||
(call-with-escape-continuation
|
||
(lambda (return)
|
||
(with-exception-handler
|
||
(lambda (exn)
|
||
(call-with-values
|
||
(lambda ()
|
||
(exception-handler exn request))
|
||
return))
|
||
(lambda ()
|
||
(start-stack #t (handler request)))))))
|
||
(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)))))))))
|
||
(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
|
||
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)
|
||
(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 <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)
|
||
(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
|
||
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
|