guile-knots/knots.scm

;;; Guile Knots
;;; Copyright © 2026 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of Guile Knots.
;;;
;;; The Guile Knots is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; The Guile Knots is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (knots)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (fibers)
  #:use-module (fibers channels)
  #:use-module (fibers conditions)
  #:use-module (ice-9 format)
  #:use-module (knots backtraces)
  #:re-export (&knots-exception
               make-knots-exception
               knots-exception?
               knots-exception-stack

               print-backtrace-and-exception/knots)
  #:export (call-with-default-io-waiters

            wait-when-system-clock-behind

            call-with-sigint

            display/knots
            simple-format/knots
            format/knots

            call-with-temporary-thread

            spawn-fiber/knots))

(define (call-with-default-io-waiters thunk)
  "Run THUNK with Guile's default blocking I/O waiters active.

This is useful when restoring the default Guile I/O waiters from
within a context (like Fibers) where different I/O waiters are used,
for example when creating a new thread from a fiber."
  (parameterize
      ((current-read-waiter (@@ (ice-9 suspendable-ports)
                                default-read-waiter))
       (current-write-waiter (@@ (ice-9 suspendable-ports)
                                 default-write-waiter)))
    (thunk)))

(define (wait-when-system-clock-behind)
  "Block until the system clock reads at least 2001-01-02.

Useful at startup in environments (virtual machines, embedded systems)
where the clock may start at or near the Unix epoch.  Prints a warning
to the current error port every 20 seconds while waiting."
  ;; Jan 02 2001 02:00:00
  (let ((start-of-the-year-2001 978400800))
    (while (< (current-time)
              start-of-the-year-2001)
      (simple-format (current-error-port)
                     "warning: system clock potentially behind, waiting\n")
      (sleep 20))))

;; Copied from (fibers web server)
(define (call-with-sigint thunk cvar)
  "Run THUNK with a SIGINT handler that signals the Fibers condition
CVAR.  Restores the previous handler when THUNK returns.

Typical usage is to pass a condition variable to this procedure and
wait on CVAR in a fiber to implement clean shutdown on Ctrl-C:

@example
(let ((quit-cvar (make-condition)))
  (call-with-sigint
    (lambda () (wait quit-cvar))
    quit-cvar))
@end example"
  (let ((handler #f))
    (dynamic-wind
      (lambda ()
        (set! handler
          (sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
      thunk
      (lambda ()
        (if handler
            ;; restore Scheme handler, SIG_IGN or SIG_DFL.
            (sigaction SIGINT (car handler) (cdr handler))
            ;; restore original C handler.
            (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 ()
       (call-with-default-io-waiters
        (lambda ()
         (with-exception-handler
             (lambda (exn)
               (put-message channel `(exception . ,exn)))
           (lambda ()
             (with-exception-handler
                 (lambda (exn)
                   (let ((stack
                          (match (fluid-ref %stacks)
                            ((stack-tag . prompt-tag)
                             (make-stack #t
                                         0 prompt-tag
                                         0 (and prompt-tag 1)))
                            (_
                             (make-stack #t)))))
                     (raise-exception
                      (make-exception
                       exn
                       (make-knots-exception stack)))))
               (lambda ()
                 (call-with-values thunk
                   (lambda values
                     (put-message channel `(values ,@values)))))))
           #:unwind? #t)))))

    (match (get-message channel)
      (('values . results)
       (apply values results))
      (('exception . exn)
       (raise-exception exn)))))

(define* (display/knots obj #:optional (port (current-output-port)))
  "Write OBJ to PORT (default: current output port) as a UTF-8 byte
sequence via @code{put-bytevector}.

When used with ports without buffering, this should be safer than
display."
  (put-bytevector
   port
   (string->utf8
    (call-with-output-string
      (lambda (port)
        (display obj port))))))

(define (simple-format/knots port s . args)
  "Like @code{simple-format} but should be safer when used with a port
without buffering."
  (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)
  "Like @code{format} but should be safer when used with a port
without buffering."
  (let ((str (apply format #f s args)))
    (if (eq? #f port)
        str
        (display/knots
         str
         (if (eq? #t port)
             (current-output-port)
             port)))))

(define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?)
  "Spawn a fiber to run THUNK, with knots exception handling.

Accepts the same optional SCHEDULER and @code{#:parallel?} arguments
as @code{spawn-fiber}."
  (spawn-fiber
   (lambda ()
     (with-exception-handler
         (lambda (exn)
           (display/knots "Uncaught exception in task:\n"
                          (current-error-port))
           (print-backtrace-and-exception/knots exn))
       (lambda ()
         (with-exception-handler
             (lambda (exn)
               (let ((stack
                      (match (fluid-ref %stacks)
                        ((stack-tag . prompt-tag)
                         (make-stack #t
                                     0 prompt-tag
                                     0 (and prompt-tag 1)))
                        (_
                         (make-stack #t)))))
                 (raise-exception
                  (make-exception
                   exn
                   (make-knots-exception stack)))))
           thunk))
       #:unwind? #t))
   scheduler
   #:parallel? parallel?))