cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rework handling of using a proc for the web server response body

Browse source 
To address encoding issues and improve exception handling.
This commit is contained in:
Christopher Baines 2025-02-03 11:25:11 +01:00
parent 40cf026ea4
commit 41974a6817
2 changed files with 134 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

104
knots/web-server.scm
View file

@ -39,6 +39,8 @@
#:use-module (knots non-blocking) #:use-module (knots non-blocking)
#:export (run-knots-web-server #:export (run-knots-web-server
make-chunked-output-port/knots
default-write-response-exception-handler default-write-response-exception-handler
web-server? web-server?
@ -52,6 +54,37 @@
(bind sock family addr port) (bind sock family addr port)
sock)) 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-response r k v . additional)
(define (extend-alist alist k v) (define (extend-alist alist k v)
(let ((pair (assq k alist))) (let ((pair (assq k alist)))
@ -249,61 +282,62 @@ on the procedure being called at any particular time."
(lambda () (lambda ()
(write-response response client) (write-response response client)
(let ((body-written? (let* ((change-client-port-encoding?
(and (procedure? body)
(not (response-content-length response))))
(body-written?
(if (procedure? body) (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) (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 (with-exception-handler
(lambda (exn) (lambda (exn)
#f) #f)
(lambda () (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 (with-exception-handler
(lambda (exn) (lambda (exn)
#f) (let* ((stack (make-stack #t))
(lambda () (error-string
(with-throw-handler #t (call-with-output-string
(lambda () (lambda (port)
(body chunked-port)
(close-port chunked-port))
(lambda (key . args)
(let ((stack (make-stack #t)))
(print-exception (print-exception
(current-error-port) port
(stack-ref stack 2) (stack-ref stack 2)
key '%exception
args) (list exn))
(display-backtrace (display-backtrace
stack stack
(current-error-port) port
2)))) 2)))))
(display error-string
(current-error-port)))
(raise-exception exn))
(lambda ()
(body body-port)))
#t) #t)
#:unwind? #t))) #:unwind? #t)))
(unless (response-content-length response)
(close-port body-port))
body-written?))
(begin (begin
(put-bytevector client body) (put-bytevector client body)
#t)))) #t))))
(if body-written? (if body-written?
(begin (begin
(force-output client) (force-output client)
(when change-client-port-encoding?
(set-port-encoding! client "ISO-8859-1"))
(keep-alive? response)) (keep-alive? response))
#f))) #f)))
#:unwind? #t)))) #:unwind? #t))))

52
tests/web-server.scm
View file

@ -1,4 +1,7 @@
(use-modules (srfi srfi-71) (use-modules (srfi srfi-71)
(rnrs bytevectors)
(ice-9 binary-ports)
(ice-9 textual-ports)
(tests) (tests)
(fibers) (fibers)
(fibers channels) (fibers channels)
@ -30,6 +33,55 @@
uri uri
#:port (non-blocking-open-socket-for-uri uri))))))) #:port (non-blocking-open-socket-for-uri uri)))))))
(run-fibers-for-tests
(lambda ()
(let* ((web-server
(run-knots-web-server
(lambda (request)
(values '((content-type . (text/plain))
(content-length . 3))
(lambda (port)
(display "foo" port))))
#:port 0)) ;; Bind to any port
(port
(web-server-port web-server))
(uri
(build-uri 'http #:host "127.0.0.1" #:port port)))
(let ((response
body
(http-get
uri
#:port (non-blocking-open-socket-for-uri uri))))
(assert-equal
"foo"
body)))))
(run-fibers-for-tests
(lambda ()
(let* ((web-server
(run-knots-web-server
(lambda (request)
(values '((content-type . (text/plain
(charset . "utf-8"))))
(lambda (port)
(display "☺" port))))
#:port 0)) ;; Bind to any port
(port
(web-server-port web-server))
(uri
(build-uri 'http #:host "127.0.0.1" #:port port)))
(let ((response
body
(http-get
uri
#:port (non-blocking-open-socket-for-uri uri))))
(assert-equal
"☺"
body)))))
;; Test hanlding of exceptions when writing the response to a client
(run-fibers-for-tests (run-fibers-for-tests
(lambda () (lambda ()
(let* ((exception-handled-sucecssfully-channel (let* ((exception-handled-sucecssfully-channel