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

130
knots/web-server.scm
View file

@ -39,6 +39,8 @@
#:use-module (knots non-blocking)
#:export (run-knots-web-server
make-chunked-output-port/knots
default-write-response-exception-handler
web-server?
@ -52,6 +54,37 @@
(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)))
@ -249,61 +282,62 @@ on the procedure being called at any particular time."
(lambda ()
(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 (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)))
(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)
(let* ((stack (make-stack #t))
(error-string
(call-with-output-string
(lambda (port)
(print-exception
port
(stack-ref stack 2)
'%exception
(list exn))
(display-backtrace
stack
port
2)))))
(display error-string
(current-error-port)))
(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))))