cbaines/guile-knots
1
Fork 0
Code Issues Pull requests Activity Actions

Add a post-request-hook to the web server
All checks were successful
/ test (push) Successful in 11s
Details

Browse source
This commit is contained in:
Christopher Baines 2025-07-01 12:45:12 +01:00
parent ce1b710bcf
commit ff93dc1442
1 changed files with 41 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

51
knots/web-server.scm
View file

@ -341,16 +341,19 @@ on the procedure being called at any particular time."
(string->utf8 (string->utf8
"internal server error"))) "internal server error")))
(define (handle-request handler client (define* (handle-request handler client
read-request-exception-handler read-request-exception-handler
write-response-exception-handler write-response-exception-handler
buffer-size) buffer-size
#:key post-request-hook)
(let ((request (let ((request
(with-exception-handler (with-exception-handler
read-request-exception-handler read-request-exception-handler
(lambda () (lambda ()
(read-request client)) (read-request client))
#:unwind? #t))) #:unwind? #t))
(read-request-time
(get-internal-real-time)))
(let ((response (let ((response
body body
(cond (cond
@ -399,7 +402,9 @@ on the procedure being called at any particular time."
(lambda () (lambda ()
(write-response response client) (write-response response client)
(let ((body-written? (let ((response-start-time
(get-internal-real-time))
(body-written?
(if (procedure? body) (if (procedure? body)
(let* ((type (response-content-type response (let* ((type (response-content-type response
'(text/plain))) '(text/plain)))
@ -438,6 +443,11 @@ on the procedure being called at any particular time."
(if body-written? (if body-written?
(begin (begin
(force-output client) (force-output client)
(when post-request-hook
(post-request-hook request
#:read-request-time read-request-time
#:response-start-time response-start-time
#:response-end-time (get-internal-real-time)))
(when (and (procedure? body) (when (and (procedure? body)
(response-content-length response)) (response-content-length response))
(set-port-encoding! client "ISO-8859-1")) (set-port-encoding! client "ISO-8859-1"))
@ -449,7 +459,8 @@ on the procedure being called at any particular time."
read-request-exception-handler read-request-exception-handler
write-response-exception-handler write-response-exception-handler
connection-idle-timeout connection-idle-timeout
buffer-size) buffer-size
post-request-hook)
;; Always disable Nagle's algorithm, as we handle buffering ;; Always disable Nagle's algorithm, as we handle buffering
;; ourselves; when we force-output, we really want the data to go ;; ourselves; when we force-output, we really want the data to go
;; out. ;; out.
@ -488,11 +499,28 @@ on the procedure being called at any particular time."
(let ((keep-alive? (handle-request handler client (let ((keep-alive? (handle-request handler client
read-request-exception-handler read-request-exception-handler
write-response-exception-handler write-response-exception-handler
buffer-size))) buffer-size
#:post-request-hook
post-request-hook)))
(if keep-alive? (if keep-alive?
(loop) (loop)
(close-port client))))))) (close-port client)))))))
(define (post-request-hook/safe post-request-hook)
(if post-request-hook
(lambda args
(with-exception-handler
(lambda (exn) #f)
(lambda ()
(with-exception-handler
(lambda (exn)
(print-backtrace-and-exception/knots exn)
(raise-exception exn))
(lambda ()
(apply post-request-hook args))))
#:unwind? #t))
#f))
(define-record-type <web-server> (define-record-type <web-server>
(make-web-server socket port) (make-web-server socket port)
web-server? web-server?
@ -512,7 +540,8 @@ on the procedure being called at any particular time."
(write-response-exception-handler (write-response-exception-handler
default-write-response-exception-handler) default-write-response-exception-handler)
(connection-idle-timeout #f) (connection-idle-timeout #f)
(connection-buffer-size 1024)) (connection-buffer-size 1024)
post-request-hook)
"Run the knots web server. "Run the knots web server.
HANDLER should be a procedure that takes one argument, the HTTP HANDLER should be a procedure that takes one argument, the HTTP
@ -548,7 +577,9 @@ before sending back to the client."
read-request-exception-handler read-request-exception-handler
write-response-exception-handler write-response-exception-handler
connection-idle-timeout connection-idle-timeout
connection-buffer-size)) connection-buffer-size
(post-request-hook/safe
post-request-hook)))
#:parallel? #t) #:parallel? #t)
(loop)))))) (loop))))))