Fix call to documenta

As enabled by Guile Documenta 0.4.

.forgejo/workflows/build-website.yaml

@@ -1,7 +1,7 @@
 on:
   push:
     branches:
-      - actions-test
+      - trunk
 jobs:
   test:
     runs-on: host
@@ -10,13 +10,17 @@ jobs:
       - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git --branch=pages knots-pages
       - run: |
           cd knots-trunk
-          guix shell -D -f guix-dev.scm -- documenta api knots
+          guix shell -D -f guix-dev.scm -- documenta api "knots.scm knots/"
           guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -c SHOW_TITLE=true -o ../knots-pages/index.html doc/index.texi
 
       - run: |
           cd knots-pages
           git add .
-          git config user.email ""
+          if [[ -z "$(git status -s)" ]]; then
-          git config user.name "Automatic website updater"
+            echo "Nothing to push"
-          git commit -m "Automatic website update"
+          else
-          git push
+            git config user.email ""
+            git config user.name "Automatic website updater"
+            git commit -m "Automatic website update"
+            git push
+          fi

knots/parallelism.scm

@@ -20,6 +20,9 @@
 (define-module (knots parallelism)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-71)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-43)
   #:use-module (ice-9 match)
   #:use-module (ice-9 control)
   #:use-module (ice-9 exceptions)
@@ -27,6 +30,7 @@
   #:use-module (fibers channels)
   #:use-module (fibers operations)
   #:use-module (knots)
+  #:use-module (knots resource-pool)
   #:export (fibers-batch-map
             fibers-map
 
@@ -38,7 +42,13 @@
             fibers-parallel
             fibers-let
 
-            fiberize))
+            fiberize
+
+            make-parallelism-limiter
+            parallelism-limiter?
+            destroy-parallelism-limiter
+            call-with-parallelism-limiter
+            with-parallelism-limiter))
 
 (define (defer-to-parallel-fiber thunk)
   (let ((reply (make-channel)))
@@ -48,7 +58,7 @@
            (lambda (exn)
              (put-message
               reply
-              (list 'exception exn)))
+              (cons 'exception exn)))
          (lambda ()
            (with-exception-handler
                (lambda (exn)
@@ -69,7 +79,7 @@
                    (lambda ()
                      (start-stack #t (thunk)))
                  (lambda vals
-                   (put-message reply vals))))))
+                   (put-message reply (cons 'result vals)))))))
          #:unwind? #t))
      #:parallel? #t)
     reply))
@@ -79,13 +89,16 @@
                         reply-channels)))
     (map
      (match-lambda
-       (('exception exn)
+       (('exception . exn)
         (raise-exception exn))
-       (result
+       (('result . vals)
-        (apply values result)))
+        (apply values vals)))
      responses)))
 
 (define (fibers-batch-map proc parallelism-limit . lists)
+  "Map PROC over LISTS in parallel, with a PARALLELISM-LIMIT.  If any of
+the invocations of PROC raise an exception, this will be raised once
+all of the calls to PROC have finished."
   (define vecs (map (lambda (list-or-vec)
                       (if (vector? list-or-vec)
                           list-or-vec
@@ -105,9 +118,18 @@
              (channel-indexes '()))
     (if (and (eq? #f next-to-process-index)
              (null? channel-indexes))
-        (if (vector? (first lists))
+        (let ((processed-result-vec
-            result-vec
+               (vector-map
-            (vector->list result-vec))
+                (lambda (_ result-or-exn)
+                  (match result-or-exn
+                    (('exception . exn)
+                     (raise-exception exn))
+                    (('result . vals)
+                     (car vals))))
+                result-vec)))
+          (if (vector? (first lists))
+              processed-result-vec
+              (vector->list processed-result-vec)))
 
         (if (or (= (length channel-indexes)
                    (min parallelism-limit vecs-length))
@@ -123,18 +145,13 @@
                          (get-operation
                           (vector-ref result-vec index))
                          (lambda (result)
-                           (match result
+                           (vector-set! result-vec
-                             (('exception exn)
+                                        index
-                              (raise-exception exn))
+                                        result)
-                             (_
+                           (values next-to-process-index
-                              (vector-set! result-vec
+                                   (lset-difference =
-                                           index
+                                                    channel-indexes
-                                           (first result))
+                                                    (list index))))))
-
-                              (values next-to-process-index
-                                      (lset-difference =
-                                                       channel-indexes
-                                                       (list index))))))))
                       channel-indexes)))))
               (loop new-index
                     new-channel-indexes))
@@ -157,9 +174,14 @@
                           channel-indexes)))))))
 
 (define (fibers-map proc . lists)
+  "Map PROC over LISTS in parallel, running up to 20 fibers in
+ PARALLEL.  If any of the invocations of PROC raise an exception, this
+will be raised once all of the calls to PROC have finished."
   (apply fibers-batch-map proc 20 lists))
 
 (define (fibers-batch-for-each proc parallelism-limit . lists)
+  "Call PROC on LISTS, running up to PARALLELISM-LIMIT fibers in
+parallel."
   (apply fibers-batch-map
          (lambda args
            (apply proc args)
@@ -170,10 +192,13 @@
   *unspecified*)
 
 (define (fibers-for-each proc . lists)
+  "Call PROC on LISTS, running up to 20 fibers in parallel."
   (apply fibers-batch-for-each proc 20 lists))
 
 (define-syntax fibers-parallel
   (lambda (x)
+    "Run each expression in parallel.  If any expression raises an
+ exception, this will be raised after all exceptions have finished."
     (syntax-case x ()
       ((_ e0 ...)
        (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
@@ -184,12 +209,16 @@
              (apply values (fetch-result-of-defered-thunks tmp0 ...))))))))
 
 (define-syntax-rule (fibers-let ((v e) ...) b0 b1 ...)
+  "Let, but run each binding in a fiber in parallel."
   (call-with-values
       (lambda () (fibers-parallel e ...))
     (lambda (v ...)
       b0 b1 ...)))
 
 (define* (fibers-map-with-progress proc lists #:key report)
+  "Map PROC over LISTS, calling #:REPORT if specified after each
+invocation of PROC finishes.  REPORT is passed the results for each
+ element of LISTS, or #f if no result has been received yet."
   (let loop ((channels-to-results
               (apply map
                      (lambda args
@@ -210,8 +239,8 @@
            (match-lambda
              ((#f . ('exception . exn))
               (raise-exception exn))
-             ((#f . ('result . val))
+             ((#f . ('result . vals))
-              val))
+              (car vals)))
            channels-to-results)
           (loop
            (perform-operation
@@ -228,12 +257,7 @@
                           (map (match-lambda
                                  ((c . r)
                                   (if (eq? channel c)
-                                      (cons #f
+                                      (cons #f result)
-                                            (match result
-                                              (('exception . exn)
-                                               result)
-                                              (_
-                                               (cons 'result result))))
                                       (cons c r))))
                                channels-to-results)))
                        #f))))
@@ -254,7 +278,7 @@
              reply-channel
              (with-exception-handler
                  (lambda (exn)
-                   (list 'exception exn))
+                   (cons 'exception exn))
                (lambda ()
                  (with-exception-handler
                      (lambda (exn)
@@ -285,5 +309,32 @@
       (put-message input-channel (cons reply-channel args))
       (match (get-message reply-channel)
         (('result . vals) (apply values vals))
-        (('exception exn)
+        (('exception . exn)
          (raise-exception exn))))))
+
+(define-record-type <parallelism-limiter>
+  (make-parallelism-limiter-record resource-pool)
+  parallelism-limiter?
+  (resource-pool     parallelism-limiter-resource-pool))
+
+(define* (make-parallelism-limiter limit #:key (name "unnamed"))
+  (make-parallelism-limiter-record
+   (make-fixed-size-resource-pool
+    (iota limit)
+    #:name name)))
+
+(define (destroy-parallelism-limiter parallelism-limiter)
+  (destroy-resource-pool
+   (parallelism-limiter-resource-pool
+    parallelism-limiter)))
+
+(define* (call-with-parallelism-limiter parallelism-limiter thunk)
+  (call-with-resource-from-pool
+      (parallelism-limiter-resource-pool parallelism-limiter)
+    (lambda _
+      (thunk))))
+
+(define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...)
+  (call-with-parallelism-limiter
+      parallelism-limiter
+    (lambda () exp ...)))

knots/thread-pool.scm

@@ -198,7 +198,7 @@ from there, or #f if that would be an empty string."
    (record-accessor &thread-pool-timeout-error 'pool)))
 
 (define thread-pool-timeout-error?
-  (record-predicate &thread-pool-timeout-error))
+  (exception-predicate &thread-pool-timeout-error))
 
 (define* (make-fixed-size-thread-pool size
                                       #:key

knots/timeout.scm

@@ -85,7 +85,7 @@
   (record-constructor &port-timeout-error))
 
 (define port-timeout-error?
-  (record-predicate &port-timeout-error))
+  (exception-predicate &port-timeout-error))
 
 (define &port-read-timeout-error
   (make-exception-type '&port-read-timeout-error
@@ -96,7 +96,7 @@
   (record-constructor &port-read-timeout-error))
 
 (define port-read-timeout-error?
-  (record-predicate &port-read-timeout-error))
+  (exception-predicate &port-read-timeout-error))
 
 (define &port-write-timeout-error
   (make-exception-type '&port-write-timeout-error
@@ -107,7 +107,7 @@
   (record-constructor &port-write-timeout-error))
 
 (define port-write-timeout-error?
-  (record-predicate &port-write-timeout-error))
+  (exception-predicate &port-write-timeout-error))
 
 (define (readable? port)
   "Test if PORT is writable."

knots/web-server.scm

@@ -63,6 +63,14 @@
     (bind sock family addr port)
     sock))
 
+(define crlf-bv
+  (string->utf8 "\r\n"))
+
+(define (chunked-output-port-overhead-bytes write-size)
+  (+ (string-length (number->string write-size 16))
+     (bytevector-length crlf-bv)
+     (bytevector-length crlf-bv)))
+
 (define* (make-chunked-output-port/knots port #:key (keep-alive? #f)
                                          (buffering 1200))
   "Returns a new port which translates non-encoded data into a HTTP
@@ -74,10 +82,12 @@ when done, as it will output the remaining data, and encode the final
 zero chunk. When the port is closed it will also close PORT, unless
 KEEP-ALIVE? is true."
   (define (write! bv start count)
-    (put-string port (number->string count 16))
+    (let ((len-string
-    (put-string port "\r\n")
+           (number->string count 16)))
+      (put-string port len-string))
+    (put-bytevector port crlf-bv 0 2)
     (put-bytevector port bv start count)
-    (put-string port "\r\n")
+    (put-bytevector port crlf-bv 0 2)
     (force-output port)
     count)
 
@@ -130,7 +140,7 @@ closes PORT, unless KEEP-ALIVE? is true."
   (record-constructor &request-body-ended-prematurely))
 
 (define request-body-ended-prematurely-error?
-  (record-predicate &request-body-ended-prematurely))
+  (exception-predicate &request-body-ended-prematurely))
 
 (define (request-body-port/knots r)
   (cond
@@ -331,15 +341,19 @@ on the procedure being called at any particular time."
           (string->utf8
            "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
+                         #:key post-request-hook)
   (let ((request
          (with-exception-handler
              read-request-exception-handler
            (lambda ()
              (read-request client))
-           #:unwind? #t)))
+           #:unwind? #t))
+        (read-request-time
+         (get-internal-real-time)))
     (let ((response
            body
            (cond
@@ -388,7 +402,9 @@ on the procedure being called at any particular time."
         (lambda ()
           (write-response response client)
 
-          (let ((body-written?
+          (let ((response-start-time
+                 (get-internal-real-time))
+                (body-written?
                  (if (procedure? body)
                      (let* ((type (response-content-type response
                                                          '(text/plain)))
@@ -399,7 +415,11 @@ on the procedure being called at any particular time."
                                  client
                                  (make-chunked-output-port/knots
                                   client
-                                  #:keep-alive? #t))))
+                                  #:keep-alive? #t
+                                  #:buffering
+                                  (- buffer-size
+                                     (chunked-output-port-overhead-bytes
+                                      buffer-size))))))
                        (set-port-encoding! body-port charset)
                        (let ((body-written?
                               (with-exception-handler
@@ -423,6 +443,11 @@ on the procedure being called at any particular time."
             (if body-written?
                 (begin
                   (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)
                              (response-content-length response))
                     (set-port-encoding! client "ISO-8859-1"))
@@ -434,7 +459,8 @@ on the procedure being called at any particular time."
                       read-request-exception-handler
                       write-response-exception-handler
                       connection-idle-timeout
-                      buffer-size)
+                      buffer-size
+                      post-request-hook)
   ;; Always disable Nagle's algorithm, as we handle buffering
   ;; ourselves; when we force-output, we really want the data to go
   ;; out.
@@ -472,11 +498,29 @@ on the procedure being called at any particular time."
      (else
       (let ((keep-alive? (handle-request handler client
                                          read-request-exception-handler
-                                         write-response-exception-handler)))
+                                         write-response-exception-handler
+                                         buffer-size
+                                         #:post-request-hook
+                                         post-request-hook)))
         (if keep-alive?
             (loop)
             (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>
   (make-web-server socket port)
   web-server?
@@ -496,7 +540,8 @@ on the procedure being called at any particular time."
                                (write-response-exception-handler
                                 default-write-response-exception-handler)
                                (connection-idle-timeout #f)
-                               (connection-buffer-size 1024))
+                               (connection-buffer-size 1024)
+                               post-request-hook)
   "Run the knots web server.
 
 HANDLER should be a procedure that takes one argument, the HTTP
@@ -532,7 +577,9 @@ before sending back to the client."
                                       read-request-exception-handler
                                       write-response-exception-handler
                                       connection-idle-timeout
-                                      connection-buffer-size))
+                                      connection-buffer-size
+                                      (post-request-hook/safe
+                                       post-request-hook)))
                        #:parallel? #t)
           (loop))))))
 

tests.scm

@@ -1,10 +1,11 @@
 (define-module (tests)
   #:use-module (ice-9 exceptions)
   #:use-module (fibers)
+  #:use-module (knots)
   #:export (run-fibers-for-tests
             assert-no-heap-growth))
 
-(define (run-fibers-for-tests thunk)
+(define* (run-fibers-for-tests thunk #:key (drain? #t))
   (let ((result
          (run-fibers
           (lambda ()
@@ -12,15 +13,18 @@
                 (lambda (exn)
                   exn)
               (lambda ()
+                (simple-format #t "running ~A\n" thunk)
                 (with-exception-handler
                     (lambda (exn)
-                      (backtrace)
+                      (print-backtrace-and-exception/knots exn)
                       (raise-exception exn))
-                  thunk)
+                  (lambda ()
+                    (start-stack #t (thunk))))
                 #t)
               #:unwind? #t))
           #:hz 0
-          #:parallelism 1)))
+          #:parallelism 1
+          #:drain? drain?)))
     (if (exception? result)
         (raise-exception result)
         result)))

tests/parallelism.scm

@@ -61,6 +61,24 @@
     identity
     '(()))))
 
+(run-fibers-for-tests
+ (lambda ()
+   (with-exception-handler
+       (lambda (exn)
+         (unless (and (exception-with-message? exn)
+                      (string=? (exception-message exn)
+                                "foo"))
+           (raise-exception exn)))
+     (lambda ()
+       (fibers-map-with-progress
+        (lambda _
+          (raise-exception
+           (make-exception-with-message "foo")))
+        '((1)))
+
+       (error 'should-not-reach-here))
+     #:unwind? #t)))
+
 (run-fibers-for-tests
  (lambda ()
    (with-exception-handler
@@ -111,4 +129,16 @@
 
      (assert-equal a 1))))
 
+(run-fibers-for-tests
+ (lambda ()
+   (let ((parallelism-limiter (make-parallelism-limiter 2)))
+     (fibers-for-each
+      (lambda _
+        (with-parallelism-limiter
+         parallelism-limiter
+         #f))
+      (iota 50))
+
+     (destroy-parallelism-limiter parallelism-limiter))))
+
 (display "parallelism test finished successfully\n")

tests/resource-pool.scm

@@ -19,7 +19,21 @@
       (number?
        (with-resource-from-pool resource-pool
            res
-         res))))))
+         res)))
+
+     (destroy-resource-pool resource-pool))))
+
+(run-fibers-for-tests
+ (lambda ()
+   (let ((resource-pool (make-fixed-size-resource-pool
+                         (list 1))))
+     (assert-true
+      (number?
+       (with-resource-from-pool resource-pool
+           res
+         res)))
+
+     (destroy-resource-pool resource-pool))))
 
 (run-fibers-for-tests
  (lambda ()
@@ -31,7 +45,9 @@
       (number?
        (with-resource-from-pool resource-pool
            res
-         res))))))
+         res)))
+
+     (destroy-resource-pool resource-pool))))
 
 (let* ((error-constructor
         (record-constructor &resource-pool-timeout))
@@ -88,10 +104,13 @@
           res))
       (iota 20))
 
-     (let loop ((stats (resource-pool-stats resource-pool)))
+     (let loop ((stats (resource-pool-stats resource-pool
+                                            #:timeout #f)))
        (unless (= 0 (assq-ref stats 'resources))
          (sleep 0.1)
-         (loop (resource-pool-stats resource-pool)))))))
+         (loop (resource-pool-stats resource-pool #:timeout #f))))
+
+     (destroy-resource-pool resource-pool))))
 
 (run-fibers-for-tests
  (lambda ()
@@ -115,7 +134,9 @@
                 (set! counter (+ 1 counter))
                 (error "collision detected")))))
       20
-      (iota 50)))))
+      (iota 50))
+
+     (destroy-resource-pool resource-pool))))
 
 (run-fibers-for-tests
  (lambda ()
@@ -129,7 +150,7 @@
                                   (error "collision detected")))
                             (new-number))
                           1
-                          #:default-checkout-timeout 120)))
+                          #:default-checkout-timeout 5)))
      (fibers-batch-for-each
       (lambda _
         (with-resource-from-pool
@@ -140,7 +161,9 @@
                 (set! counter (+ 1 counter))
                 (error "collision detected")))))
       20
-      (iota 50)))))
+      (iota 50))
+
+     (destroy-resource-pool resource-pool))))
 
 (run-fibers-for-tests
  (lambda ()
@@ -164,14 +187,14 @@
                 (call-with-resource-from-pool
                     resource-pool
                   (lambda (res)
-                    (error 'should-not-be-reached))))
+                    #f)))
               #:unwind? #t)))
 
          (while (= 0
                    (assq-ref
-                    (resource-pool-stats resource-pool)
+                    (resource-pool-stats resource-pool #:timeout #f)
                     'waiters))
-           (sleep 0))
+           (sleep 0.1))
 
          (with-exception-handler
              (lambda (exn)
@@ -184,6 +207,8 @@
                  resource-pool
                (lambda (res)
                  (error 'should-not-be-reached))))
-           #:unwind? #t))))))
+           #:unwind? #t)))
+
+     (destroy-resource-pool resource-pool))))
 
 (display "resource-pool test finished successfully\n")