Address issue with failures when creating resource pool resources

Previously failures could lead to no resources in the pool, and
waiters which will never get a resource. Retrying here fixes that
issue, although maybe another approach is needed that keeps track of
new resources being created, as that'll allow keeping track of this
when destroying resource pools.

knots.scm

@@ -1,7 +1,9 @@
 (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)
@@ -11,6 +13,10 @@
 
             call-with-sigint
 
+            display/knots
+            simple-format/knots
+            format/knots
+
             &knots-exception
             make-knots-exception
             knots-exception?
@@ -51,6 +57,34 @@
             ;; 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
@@ -135,13 +169,19 @@
          (error-string
           (with-exception-handler
               (lambda (exn)
-                (display (get-output-string string-port)
-                         port)
+                (display/knots (get-output-string string-port)
+                               port)
                 (close-output-port string-port)
-                (display "\n\n" port)
+                (display/knots "\n\n" port)
 
-                (backtrace port)
-                (simple-format
+                (let* ((stack (make-stack #t))
+                       (backtrace
+                        (call-with-output-string
+                          (lambda (port)
+                            (display-backtrace stack port)
+                            (newline port)))))
+                  (display/knots backtrace))
+                (simple-format/knots
                  port
                  "\nexception in print-backtrace-and-exception/knots: ~A\n"
                  exn)
@@ -151,15 +191,15 @@
               (let ((str (get-output-string string-port)))
                 (close-output-port string-port)
                 str)))))
-    (display error-string port)))
+    (display/knots error-string port)))
 
 (define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?)
   (spawn-fiber
    (lambda ()
      (with-exception-handler
          (lambda (exn)
-           (display "Uncaught exception in task:\n"
-                    (current-error-port))
+           (display/knots "Uncaught exception in task:\n"
+                          (current-error-port))
            (print-backtrace-and-exception/knots exn))
        (lambda ()
          (with-exception-handler

knots/resource-pool.scm

@@ -90,7 +90,7 @@
 (set-record-type-printer!
  <resource-pool>
  (lambda (resource-pool port)
-   (display
+   (display/knots
     (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 error-string
-                          (current-error-port)))
+                 (display/knots error-string
+                                (current-error-port)))
                (raise-exception exn))
            (lambda ()
              (start-stack
@@ -562,31 +562,43 @@
                  #f
                  (raise-exception exn)))
          (lambda ()
-           (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)))))
+           (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))))))))
          #:unwind? #t))))
 
   (define (spawn-fiber-to-destroy-resource resource-id resource-value)
@@ -1146,8 +1158,8 @@
                             (stack-ref stack 3)
                             '%exception
                             (list exn))))))
-                 (display error-string
-                          (current-error-port)))
+                 (display/knots error-string
+                                (current-error-port)))
                (raise-exception exn))
            (lambda ()
              (start-stack

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 "While reading request:\n" (current-error-port))
+  (display/knots "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
+      (simple-format/knots
        (current-error-port)
        "~A ~A: error replying to client\n"
        (request-method request)
        (uri-path (request-uri request)))
-      (simple-format
+      (simple-format/knots
        (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 error-string
-             (current-error-port)))
+    (display/knots error-string
+                   (current-error-port)))
 
   (values (build-response #:code 500)
           ;; TODO Make this configurable
@@ -476,13 +476,17 @@ on the procedure being called at any particular time."
             (unless (and (exception-with-origin? exn)
                          (string=? (exception-origin exn)
                                    "fport_read"))
-              (display "knots web-server, exception in client loop:\n"
-                       (current-error-port))
-              (print-exception
-               (current-error-port)
-               #f
-               '%exception
-               (list exn)))
+              (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)))
             #t)
         (lambda ()
           (or