From d0ff89023b9fb0ff2617b95b45af90128fe6c8c7 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 11:56:53 +0000 Subject: [PATCH] Add documentation for lots of the "undocumented" bits In the Guile Documenta generated documentation. --- knots.scm | 2 ++ knots/backtraces.scm | 34 ++++++++++++++++++++++++++++++++++ knots/parallelism.scm | 7 +++++++ knots/promise.scm | 4 ++++ knots/resource-pool.scm | 36 ++++++++++++++++++++++++++++++++++++ knots/thread-pool.scm | 26 ++++++++++++++++++++++++++ knots/timeout.scm | 6 ++++++ knots/web-server.scm | 30 +++++++++++++++++++++++++----- 8 files changed, 140 insertions(+), 5 deletions(-) diff --git a/knots.scm b/knots.scm index e8e9690..2144596 100644 --- a/knots.scm +++ b/knots.scm @@ -105,6 +105,8 @@ wait on CVAR in a fiber to implement clean shutdown on Ctrl-C: (sigaction SIGINT #f)))))) (define (call-with-temporary-thread thunk) + "Run THUNK in a temporary thread and return its result to the +calling fiber." (let ((channel (make-channel))) (call-with-new-thread (lambda () diff --git a/knots/backtraces.scm b/knots/backtraces.scm index 306a469..7268311 100644 --- a/knots/backtraces.scm +++ b/knots/backtraces.scm @@ -41,14 +41,20 @@ (define make-knots-exception (record-constructor &knots-exception)) +(set-procedure-property! make-knots-exception 'documentation + "Construct a @code{&knots-exception} with the given stack.") (define knots-exception? (exception-predicate &knots-exception)) +(set-procedure-property! knots-exception? 'documentation + "Return @code{#t} if OBJ is a @code{&knots-exception}.") (define knots-exception-stack (exception-accessor &knots-exception (record-accessor &knots-exception 'stack))) +(set-procedure-property! knots-exception-stack 'documentation + "Return the stack from a @code{&knots-exception}.") (define (backtrace-debug-mode?) (let ((val (getenv "KNOTS_BACKTRACE_DEBUG"))) @@ -222,6 +228,34 @@ (define* (print-backtrace-and-exception/knots exn #:key (port (current-error-port))) + "Print the backtrace and exception information from EXN to PORT. This +procedure captures the stack, so should be run before the stack is +unwound, so using @code{with-exception-handler} without +@code{#:unwind? #t}, the exception may need to then be re-raised and +handled in an outer exception handler. + +@example +(with-exception-handler + (lambda (exn) + ;; Recover from the exception + #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (do-things)))) + #:unwind? #t) +@end example + +It's important to use @code{print-backtrace-and-exception/knots} for +displaying backtraces involving functionality from Guile Knots, since +the stack involved is potentially split across several fibers. The +stacks involved are attached to the exception, and this procedure +extracts this information out and assembles a backtrace including all +the code involved. +" (define (get-string out stack) (let* ((stack-vector (stack->vector stack)) (knots-stack-vectors diff --git a/knots/parallelism.scm b/knots/parallelism.scm index e78e6e2..393d78c 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -326,6 +326,10 @@ write directly to @code{process-channel}." (make-parallelism-limiter-record resource-pool) parallelism-limiter? (resource-pool parallelism-limiter-resource-pool)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'parallelism-limiter?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") (define* (make-parallelism-limiter limit #:key (name "unnamed")) "Return a parallelism limiter that allows at most LIMIT concurrent @@ -340,6 +344,7 @@ time. Further fibers block until a slot becomes free. #:name name))) (define (destroy-parallelism-limiter parallelism-limiter) + "Destroy PARALLELISM-LIMITER, releasing its underlying resource pool." (destroy-resource-pool (parallelism-limiter-resource-pool parallelism-limiter))) @@ -354,6 +359,8 @@ currently available." (thunk)))) (define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...) + "Evaluate EXP ... while holding a slot from PARALLELISM-LIMITER. +Syntactic sugar around @code{call-with-parallelism-limiter}." (call-with-parallelism-limiter parallelism-limiter (lambda () exp ...))) diff --git a/knots/promise.scm b/knots/promise.scm index b85fe64..8d21441 100644 --- a/knots/promise.scm +++ b/knots/promise.scm @@ -39,6 +39,10 @@ (thunk fibers-promise-thunk) (values-box fibers-promise-values-box) (evaluated-condition fibers-promise-evaluated-condition)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fibers-promise?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") (define (fibers-delay thunk) "Return a new fiber-aware promise that will evaluate THUNK when diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index f06a156..5a8e2e0 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -86,6 +86,22 @@ set-resource-pool-channel!) (destroy-condition resource-pool-destroy-condition) (configuration resource-pool-configuration)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool-name)) + 'documentation + "Return the name of the resource pool.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool-channel)) + 'documentation + "Return the channel used by the resource pool.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool-configuration)) + 'documentation + "Return the configuration alist of the resource pool.") (set-record-type-printer! @@ -1277,12 +1293,16 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-timeout (record-accessor &resource-pool-timeout 'pool))) +(set-procedure-property! resource-pool-timeout-error-pool 'documentation + "Return the pool from a @code{&resource-pool-timeout} exception.") (define make-resource-pool-timeout-error (record-constructor &resource-pool-timeout)) (define resource-pool-timeout-error? (exception-predicate &resource-pool-timeout)) +(set-procedure-property! resource-pool-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-timeout} exception.") (define &resource-pool-too-many-waiters (make-exception-type '&recource-pool-too-many-waiters @@ -1293,17 +1313,23 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'pool))) +(set-procedure-property! resource-pool-too-many-waiters-error-pool 'documentation + "Return the pool from a @code{&resource-pool-too-many-waiters} exception.") (define resource-pool-too-many-waiters-error-waiters-count (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'waiters-count))) +(set-procedure-property! resource-pool-too-many-waiters-error-waiters-count 'documentation + "Return the waiters count from a @code{&resource-pool-too-many-waiters} exception.") (define make-resource-pool-too-many-waiters-error (record-constructor &resource-pool-too-many-waiters)) (define resource-pool-too-many-waiters-error? (exception-predicate &resource-pool-too-many-waiters)) +(set-procedure-property! resource-pool-too-many-waiters-error? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-too-many-waiters} exception.") (define &resource-pool-destroyed (make-exception-type '&recource-pool-destroyed @@ -1314,12 +1340,16 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-destroyed (record-accessor &resource-pool-destroyed 'pool))) +(set-procedure-property! resource-pool-destroyed-error-pool 'documentation + "Return the pool from a @code{&resource-pool-destroyed} exception.") (define make-resource-pool-destroyed-error (record-constructor &resource-pool-destroyed)) (define resource-pool-destroyed-error? (exception-predicate &resource-pool-destroyed)) +(set-procedure-property! resource-pool-destroyed-error? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-destroyed} exception.") (define &resource-pool-destroy-resource (make-exception-type '&recource-pool-destroy-resource @@ -1328,9 +1358,13 @@ receive @code{&resource-pool-destroyed}." (define make-resource-pool-destroy-resource-exception (record-constructor &resource-pool-destroy-resource)) +(set-procedure-property! make-resource-pool-destroy-resource-exception 'documentation + "Construct a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-destroy-resource-exception? (exception-predicate &resource-pool-destroy-resource)) +(set-procedure-property! resource-pool-destroy-resource-exception? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-default-timeout-handler (make-parameter #f)) @@ -1467,6 +1501,8 @@ available. Return the resource once PROC has returned." (apply values vals))))))) (define-syntax-rule (with-resource-from-pool pool resource exp ...) + "Evaluate EXP ... with RESOURCE bound to a resource checked out from +POOL. Syntactic sugar around @code{call-with-resource-from-pool}." (call-with-resource-from-pool pool (lambda (resource) exp ...))) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index f8c44b2..aa460de 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -160,6 +160,14 @@ from there, or #f if that would be an empty string." thread-pool? (resource-pool thread-pool-resource-pool) (arguments-parameter thread-pool-arguments-parameter-accessor)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'thread-pool?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'thread-pool-resource-pool)) + 'documentation + "Return the underlying resource pool of the thread pool.") (define-record-type (fixed-size-thread-pool channel arguments-parameter current-procedures @@ -170,15 +178,29 @@ from there, or #f if that would be an empty string." (current-procedures fixed-size-thread-pool-current-procedures) (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout) (threads fixed-size-thread-pool-threads)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-channel)) + 'documentation + "Return the channel of the fixed-size thread pool.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-current-procedures)) + 'documentation + "Return the current procedures vector of the fixed-size thread pool.") ;; Since both thread pool records have this field, use a procedure ;; than handles the appropriate accessor (define (thread-pool-arguments-parameter pool) + "Return the arguments parameter for POOL, dispatching on pool type." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-arguments-parameter pool) (thread-pool-arguments-parameter-accessor pool))) (define (thread-pool-default-checkout-timeout pool) + "Return the default checkout timeout for POOL." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-default-checkout-timeout pool) (assq-ref (resource-pool-configuration @@ -197,9 +219,13 @@ from there, or #f if that would be an empty string." (exception-accessor &thread-pool-timeout-error (record-accessor &thread-pool-timeout-error 'pool))) +(set-procedure-property! thread-pool-timeout-error-pool 'documentation + "Return the pool from a @code{&thread-pool-timeout-error} exception.") (define thread-pool-timeout-error? (exception-predicate &thread-pool-timeout-error)) +(set-procedure-property! thread-pool-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&thread-pool-timeout-error} exception.") (define* (make-fixed-size-thread-pool size #:key diff --git a/knots/timeout.scm b/knots/timeout.scm index 2df2ddd..37da65e 100644 --- a/knots/timeout.scm +++ b/knots/timeout.scm @@ -95,6 +95,8 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-timeout-error? (exception-predicate &port-timeout-error)) +(set-procedure-property! port-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&port-timeout-error}.") (define &port-read-timeout-error (make-exception-type '&port-read-timeout-error @@ -106,6 +108,8 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-read-timeout-error? (exception-predicate &port-read-timeout-error)) +(set-procedure-property! port-read-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&port-read-timeout-error}.") (define &port-write-timeout-error (make-exception-type '&port-write-timeout-error @@ -117,6 +121,8 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-write-timeout-error? (exception-predicate &port-write-timeout-error)) +(set-procedure-property! port-write-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&port-write-timeout-error}.") (define (readable? port) "Test if PORT is readable." diff --git a/knots/web-server.scm b/knots/web-server.scm index b51ca00..8b328e3 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -141,23 +141,29 @@ closes PORT, unless KEEP-ALIVE? is true." (define request-body-ended-prematurely-error? (exception-predicate &request-body-ended-prematurely)) +(set-procedure-property! request-body-ended-prematurely-error? 'documentation + "Return @code{#t} if OBJ is a @code{&request-body-ended-prematurely} exception.") -(define (request-body-port/knots r) +(define (request-body-port/knots request) + "Return an input port for reading the body of request REQUEST. +Handles chunked transfer encoding." (cond - ((member '(chunked) (request-transfer-encoding r)) - (make-chunked-input-port (request-port r) + ((member '(chunked) (request-transfer-encoding request)) + (make-chunked-input-port (request-port request) #:keep-alive? #t)) (else (let ((content-length - (request-content-length r))) + (request-content-length request))) (make-delimited-input-port - (request-port r) + (request-port request) content-length (lambda (bytes-read) (raise-exception (make-request-body-ended-prematurely-error bytes-read)))))))) (define (read-request-body/knots r) + "Read and return the full body of request R as a bytevector. +Handles chunked transfer encoding." (cond ((member '(chunked) (request-transfer-encoding r)) (get-bytevector-all @@ -299,6 +305,8 @@ on the procedure being called at any particular time." #f) (define (default-write-response-exception-handler exn request) + "Default handler for exceptions raised while writing an HTTP response. +Logs the error for REQUEST to the current error port." (if (and (exception-with-origin? exn) (string=? (exception-origin exn) "fport_write")) @@ -528,6 +536,18 @@ on the procedure being called at any particular time." web-server? (socket web-server-socket) (port web-server-port)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'web-server?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'web-server-socket)) + 'documentation + "Return the socket of the web server.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'web-server-port)) + 'documentation + "Return the port number of the web server.") (define* (run-knots-web-server handler #:key (host #f)