Compare commits
No commits in common. "2770c1ad70ede355d4b630ea29818b9e508fff1c" and "39ae5177f2527169721d7d895e2953021e136bf4" have entirely different histories.
2770c1ad70
...
39ae5177f2
3 changed files with 50 additions and 106 deletions
56
knots.scm
56
knots.scm
|
|
@ -1,9 +1,7 @@
|
|||
(define-module (knots)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (ice-9 suspendable-ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (fibers)
|
||||
#:use-module (fibers conditions)
|
||||
#:use-module (system repl debug)
|
||||
|
|
@ -13,10 +11,6 @@
|
|||
|
||||
call-with-sigint
|
||||
|
||||
display/knots
|
||||
simple-format/knots
|
||||
format/knots
|
||||
|
||||
&knots-exception
|
||||
make-knots-exception
|
||||
knots-exception?
|
||||
|
|
@ -57,34 +51,6 @@
|
|||
;; restore original C handler.
|
||||
(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
|
||||
(make-exception-type '&knots-exception
|
||||
&exception
|
||||
|
|
@ -169,19 +135,13 @@
|
|||
(error-string
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(display/knots (get-output-string string-port)
|
||||
port)
|
||||
(display (get-output-string string-port)
|
||||
port)
|
||||
(close-output-port string-port)
|
||||
(display/knots "\n\n" port)
|
||||
(display "\n\n" port)
|
||||
|
||||
(let* ((stack (make-stack #t))
|
||||
(backtrace
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(display-backtrace stack port)
|
||||
(newline port)))))
|
||||
(display/knots backtrace))
|
||||
(simple-format/knots
|
||||
(backtrace port)
|
||||
(simple-format
|
||||
port
|
||||
"\nexception in print-backtrace-and-exception/knots: ~A\n"
|
||||
exn)
|
||||
|
|
@ -191,15 +151,15 @@
|
|||
(let ((str (get-output-string string-port)))
|
||||
(close-output-port string-port)
|
||||
str)))))
|
||||
(display/knots error-string port)))
|
||||
(display error-string port)))
|
||||
|
||||
(define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?)
|
||||
(spawn-fiber
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(display/knots "Uncaught exception in task:\n"
|
||||
(current-error-port))
|
||||
(display "Uncaught exception in task:\n"
|
||||
(current-error-port))
|
||||
(print-backtrace-and-exception/knots exn))
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@
|
|||
(set-record-type-printer!
|
||||
<resource-pool>
|
||||
(lambda (resource-pool port)
|
||||
(display/knots
|
||||
(display
|
||||
(simple-format #f "#<resource-pool name: \"~A\">"
|
||||
(resource-pool-name resource-pool))
|
||||
port)))
|
||||
|
|
@ -488,8 +488,8 @@
|
|||
(stack-ref stack 3)
|
||||
'%exception
|
||||
(list exn))))))
|
||||
(display/knots error-string
|
||||
(current-error-port)))
|
||||
(display error-string
|
||||
(current-error-port)))
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(start-stack
|
||||
|
|
@ -562,43 +562,31 @@
|
|||
#f
|
||||
(raise-exception exn)))
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(with-parallelism-limiter
|
||||
return-new-resource/parallelism-limiter
|
||||
(let ((max-size
|
||||
(assq-ref (resource-pool-configuration pool)
|
||||
'max-size))
|
||||
(size (count-resources resources)))
|
||||
(unless (>= size max-size)
|
||||
(let ((success?
|
||||
(with-exception-handler
|
||||
(lambda _ #f)
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"exception adding resource to pool ~A: ~A\n\n"
|
||||
name
|
||||
return-new-resource)
|
||||
(print-backtrace-and-exception/knots exn)
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(let ((new-resource
|
||||
(start-stack #t (return-new-resource))))
|
||||
(put-message channel
|
||||
(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))))))))
|
||||
(with-parallelism-limiter
|
||||
return-new-resource/parallelism-limiter
|
||||
(let ((max-size
|
||||
(assq-ref (resource-pool-configuration pool)
|
||||
'max-size))
|
||||
(size (count-resources resources)))
|
||||
(unless (>= size max-size)
|
||||
(with-exception-handler
|
||||
(lambda _ #f)
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"exception adding resource to pool ~A: ~A\n\n"
|
||||
name
|
||||
return-new-resource)
|
||||
(print-backtrace-and-exception/knots exn)
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(let ((new-resource
|
||||
(start-stack #t (return-new-resource))))
|
||||
(put-message channel
|
||||
(list 'add-resource new-resource))))))
|
||||
#:unwind? #t)))))
|
||||
#:unwind? #t))))
|
||||
|
||||
(define (spawn-fiber-to-destroy-resource resource-id resource-value)
|
||||
|
|
@ -1158,8 +1146,8 @@
|
|||
(stack-ref stack 3)
|
||||
'%exception
|
||||
(list exn))))))
|
||||
(display/knots error-string
|
||||
(current-error-port)))
|
||||
(display error-string
|
||||
(current-error-port)))
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(start-stack
|
||||
|
|
|
|||
|
|
@ -289,7 +289,7 @@ on the procedure being called at any particular time."
|
|||
(not (memq 'close (response-connection response))))
|
||||
|
||||
(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
|
||||
(current-error-port)
|
||||
#f
|
||||
|
|
@ -302,12 +302,12 @@ on the procedure being called at any particular time."
|
|||
(if (and (exception-with-origin? exn)
|
||||
(string=? (exception-origin exn)
|
||||
"fport_write"))
|
||||
(simple-format/knots
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"~A ~A: error replying to client\n"
|
||||
(request-method request)
|
||||
(uri-path (request-uri request)))
|
||||
(simple-format/knots
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"knots web server: ~A ~A: exception replying to client: ~A\n"
|
||||
(request-method request)
|
||||
|
|
@ -329,8 +329,8 @@ on the procedure being called at any particular time."
|
|||
(print-backtrace-and-exception/knots
|
||||
exn
|
||||
#:port port)))))
|
||||
(display/knots error-string
|
||||
(current-error-port)))
|
||||
(display error-string
|
||||
(current-error-port)))
|
||||
|
||||
(values (build-response #:code 500)
|
||||
;; TODO Make this configurable
|
||||
|
|
@ -476,17 +476,13 @@ on the procedure being called at any particular time."
|
|||
(unless (and (exception-with-origin? exn)
|
||||
(string=? (exception-origin exn)
|
||||
"fport_read"))
|
||||
(display/knots "knots web-server, exception in client loop:\n"
|
||||
(current-error-port))
|
||||
(display/knots
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(print-exception
|
||||
port
|
||||
#f
|
||||
'%exception
|
||||
(list exn))))
|
||||
(current-error-port)))
|
||||
(display "knots web-server, exception in client loop:\n"
|
||||
(current-error-port))
|
||||
(print-exception
|
||||
(current-error-port)
|
||||
#f
|
||||
'%exception
|
||||
(list exn)))
|
||||
#t)
|
||||
(lambda ()
|
||||
(or
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue