diff --git a/knots.scm b/knots.scm index ee38ee4..dee18a5 100644 --- a/knots.scm +++ b/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 diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 553df68..f957c3d 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -90,7 +90,7 @@ (set-record-type-printer! (lambda (resource-pool port) - (display/knots + (display (simple-format #f "#" (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 diff --git a/knots/web-server.scm b/knots/web-server.scm index adaba13..d0b13ce 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -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