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

Compare commits

base: cbaines:2770c1ad70ede355d4b630ea29818b9e508fff1c
Branches Tags
cbaines:trunk
cbaines:pages
cbaines:actions-test
..
compare: cbaines:39ae5177f2527169721d7d895e2953021e136bf4
Branches Tags
cbaines:trunk
cbaines:pages
cbaines:actions-test

No commits in common. "2770c1ad70ede355d4b630ea29818b9e508fff1c" and "39ae5177f2527169721d7d895e2953021e136bf4" have entirely different histories.
2770c1ad70 ... 39ae5177f2

3 changed files with 50 additions and 106 deletions
Download patch file Download diff file Expand all files Collapse all files

56
knots.scm
View file

@ -1,9 +1,7 @@
(define-module (knots) (define-module (knots)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 suspendable-ports) #:use-module (ice-9 suspendable-ports)
#:use-module (rnrs bytevectors)
#:use-module (fibers) #:use-module (fibers)
#:use-module (fibers conditions) #:use-module (fibers conditions)
#:use-module (system repl debug) #:use-module (system repl debug)
@ -13,10 +11,6 @@
call-with-sigint call-with-sigint
display/knots
simple-format/knots
format/knots
&knots-exception &knots-exception
make-knots-exception make-knots-exception
knots-exception? knots-exception?
@ -57,34 +51,6 @@
;; restore original C handler. ;; restore original C handler.
(sigaction SIGINT #f)))))) (sigaction SIGINT #f))))))
(define* (display/knots obj #:optional (port (current-output-port)))
(put-bytevector
port
(string->utf8
(call-with-output-string
(lambda (port)
(display obj port))))))
(define (simple-format/knots port s . args)
(let ((str (apply simple-format #f s args)))
(if (eq? #f port)
str
(display/knots
str
(if (eq? #t port)
(current-output-port)
port)))))
(define (format/knots port s . args)
(let ((str (apply format #f s args)))
(if (eq? #f port)
str
(display/knots
str
(if (eq? #t port)
(current-output-port)
port)))))
(define &knots-exception (define &knots-exception
(make-exception-type '&knots-exception (make-exception-type '&knots-exception
&exception &exception
@ -169,19 +135,13 @@
(error-string (error-string
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(display/knots (get-output-string string-port) (display (get-output-string string-port)
port) port)
(close-output-port string-port) (close-output-port string-port)
(display/knots "\n\n" port) (display "\n\n" port)
(let* ((stack (make-stack #t)) (backtrace port)
(backtrace (simple-format
(call-with-output-string
(lambda (port)
(display-backtrace stack port)
(newline port)))))
(display/knots backtrace))
(simple-format/knots
port port
"\nexception in print-backtrace-and-exception/knots: ~A\n" "\nexception in print-backtrace-and-exception/knots: ~A\n"
exn) exn)
@ -191,15 +151,15 @@
(let ((str (get-output-string string-port))) (let ((str (get-output-string string-port)))
(close-output-port string-port) (close-output-port string-port)
str))))) str)))))
(display/knots error-string port))) (display error-string port)))
(define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) (define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?)
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(display/knots "Uncaught exception in task:\n" (display "Uncaught exception in task:\n"
(current-error-port)) (current-error-port))
(print-backtrace-and-exception/knots exn)) (print-backtrace-and-exception/knots exn))
(lambda () (lambda ()
(with-exception-handler (with-exception-handler

72
knots/resource-pool.scm
View file

@ -90,7 +90,7 @@
(set-record-type-printer! (set-record-type-printer!
<resource-pool> <resource-pool>
(lambda (resource-pool port) (lambda (resource-pool port)
(display/knots (display
(simple-format #f "#<resource-pool name: \"~A\">" (simple-format #f "#<resource-pool name: \"~A\">"
(resource-pool-name resource-pool)) (resource-pool-name resource-pool))
port))) port)))
@ -488,8 +488,8 @@
(stack-ref stack 3) (stack-ref stack 3)
'%exception '%exception
(list exn)))))) (list exn))))))
(display/knots error-string (display error-string
(current-error-port))) (current-error-port)))
(raise-exception exn)) (raise-exception exn))
(lambda () (lambda ()
(start-stack (start-stack
@ -562,43 +562,31 @@
#f #f
(raise-exception exn))) (raise-exception exn)))
(lambda () (lambda ()
(let loop () (with-parallelism-limiter
(with-parallelism-limiter return-new-resource/parallelism-limiter
return-new-resource/parallelism-limiter (let ((max-size
(let ((max-size (assq-ref (resource-pool-configuration pool)
(assq-ref (resource-pool-configuration pool) 'max-size))
'max-size)) (size (count-resources resources)))
(size (count-resources resources))) (unless (>= size max-size)
(unless (>= size max-size) (with-exception-handler
(let ((success? (lambda _ #f)
(with-exception-handler (lambda ()
(lambda _ #f) (with-exception-handler
(lambda () (lambda (exn)
(with-exception-handler (simple-format
(lambda (exn) (current-error-port)
(simple-format "exception adding resource to pool ~A: ~A\n\n"
(current-error-port) name
"exception adding resource to pool ~A: ~A\n\n" return-new-resource)
name (print-backtrace-and-exception/knots exn)
return-new-resource) (raise-exception exn))
(print-backtrace-and-exception/knots exn) (lambda ()
(raise-exception exn)) (let ((new-resource
(lambda () (start-stack #t (return-new-resource))))
(let ((new-resource (put-message channel
(start-stack #t (return-new-resource)))) (list 'add-resource new-resource))))))
(put-message channel #:unwind? #t)))))
(list 'add-resource new-resource)))
#t)))
#:unwind? #t)))
(unless success?
;; TODO Maybe this should be configurable?
(sleep 1)
;; Important to retry here and eventually create
;; a new resource, as there might be waiters
;; stuck waiting for a resource, especially if
;; the pool is empty.
(loop))))))))
#:unwind? #t)))) #:unwind? #t))))
(define (spawn-fiber-to-destroy-resource resource-id resource-value) (define (spawn-fiber-to-destroy-resource resource-id resource-value)
@ -1158,8 +1146,8 @@
(stack-ref stack 3) (stack-ref stack 3)
'%exception '%exception
(list exn)))))) (list exn))))))
(display/knots error-string (display error-string
(current-error-port))) (current-error-port)))
(raise-exception exn)) (raise-exception exn))
(lambda () (lambda ()
(start-stack (start-stack

28
knots/web-server.scm
View file

@ -289,7 +289,7 @@ on the procedure being called at any particular time."
(not (memq 'close (response-connection response)))) (not (memq 'close (response-connection response))))
(define (default-read-request-exception-handler exn) (define (default-read-request-exception-handler exn)
(display/knots "While reading request:\n" (current-error-port)) (display "While reading request:\n" (current-error-port))
(print-exception (print-exception
(current-error-port) (current-error-port)
#f #f
@ -302,12 +302,12 @@ on the procedure being called at any particular time."
(if (and (exception-with-origin? exn) (if (and (exception-with-origin? exn)
(string=? (exception-origin exn) (string=? (exception-origin exn)
"fport_write")) "fport_write"))
(simple-format/knots (simple-format
(current-error-port) (current-error-port)
"~A ~A: error replying to client\n" "~A ~A: error replying to client\n"
(request-method request) (request-method request)
(uri-path (request-uri request))) (uri-path (request-uri request)))
(simple-format/knots (simple-format
(current-error-port) (current-error-port)
"knots web server: ~A ~A: exception replying to client: ~A\n" "knots web server: ~A ~A: exception replying to client: ~A\n"
(request-method request) (request-method request)
@ -329,8 +329,8 @@ on the procedure being called at any particular time."
(print-backtrace-and-exception/knots (print-backtrace-and-exception/knots
exn exn
#:port port))))) #:port port)))))
(display/knots error-string (display error-string
(current-error-port))) (current-error-port)))
(values (build-response #:code 500) (values (build-response #:code 500)
;; TODO Make this configurable ;; TODO Make this configurable
@ -476,17 +476,13 @@ on the procedure being called at any particular time."
(unless (and (exception-with-origin? exn) (unless (and (exception-with-origin? exn)
(string=? (exception-origin exn) (string=? (exception-origin exn)
"fport_read")) "fport_read"))
(display/knots "knots web-server, exception in client loop:\n" (display "knots web-server, exception in client loop:\n"
(current-error-port)) (current-error-port))
(display/knots (print-exception
(call-with-output-string (current-error-port)
(lambda (port) #f
(print-exception '%exception
port (list exn)))
#f
'%exception
(list exn))))
(current-error-port)))
#t) #t)
(lambda () (lambda ()
(or (or