Copy with-fibers-port-timeouts from the nar-herder

As this is state of the art stuff for having Guile not hang while talking to
the network.

1 files changed, 182 insertions, 0 deletions

diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm
new file mode 100644
index 0000000..cff6476
--- /dev/null
+++ b/guix-qa-frontpage/utils.scm
@@ -0,0 +1,182 @@
+;;; Guix QA Frontpage
+;;;
+;;; Copyright © 2023 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-qa-frontpage utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 q)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 exceptions)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module ((ice-9 ports internal) #:select (port-poll
+                                                 port-read-wait-fd
+                                                 port-write-wait-fd))
+  #:use-module (web uri)
+  #:use-module (web http)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (fibers)
+  #:use-module (fibers timers)
+  #:use-module (fibers channels)
+  #:use-module (fibers scheduler)
+  #:use-module (fibers conditions)
+  #:use-module (fibers operations)
+  #:export (port-read-timeout-error?
+            port-write-timeout-error?
+            with-fibers-port-timeouts))
+
+(define (readable? port)
+  "Test if PORT is writable."
+  (match (select (vector port) #() #() 0)
+    ((#() #() #()) #f)
+    ((#(_) #() #()) #t)))
+
+(define (writable? port)
+  "Test if PORT is writable."
+  (match (select #() (vector port) #() 0)
+    ((#() #() #()) #f)
+    ((#() #(_) #()) #t)))
+
+(define (make-wait-operation ready? schedule-when-ready port port-ready-fd this-procedure)
+  (make-base-operation #f
+                       (lambda _
+                         (and (ready? (port-ready-fd port)) values))
+                       (lambda (flag sched resume)
+                         (define (commit)
+                           (match (atomic-box-compare-and-swap! flag 'W 'S)
+                             ('W (resume values))
+                             ('C (commit))
+                             ('S #f)))
+                         (schedule-when-ready
+                          sched (port-ready-fd port) commit))))
+
+(define (wait-until-port-readable-operation port)
+  "Make an operation that will succeed when PORT is readable."
+  (unless (input-port? port)
+    (error "refusing to wait forever for input on non-input port"))
+  (make-wait-operation readable? schedule-task-when-fd-readable port
+                       port-read-wait-fd
+                       wait-until-port-readable-operation))
+
+(define (wait-until-port-writable-operation port)
+  "Make an operation that will succeed when PORT is writable."
+  (unless (output-port? port)
+    (error "refusing to wait forever for output on non-output port"))
+  (make-wait-operation writable? schedule-task-when-fd-writable port
+                       port-write-wait-fd
+                       wait-until-port-writable-operation))
+
+
+
+(define &port-timeout
+  (make-exception-type '&port-timeout
+                       &external-error
+                       '(port)))
+
+(define make-port-timeout-error
+  (record-constructor &port-timeout))
+
+(define port-timeout-error?
+  (record-predicate &port-timeout))
+
+(define &port-read-timeout
+  (make-exception-type '&port-read-timeout
+                       &port-timeout
+                       '()))
+
+(define make-port-read-timeout-error
+  (record-constructor &port-read-timeout))
+
+(define port-read-timeout-error?
+  (record-predicate &port-read-timeout))
+
+(define &port-write-timeout
+  (make-exception-type '&port-write-timeout
+                       &port-timeout
+                       '()))
+
+(define make-port-write-timeout-error
+  (record-constructor &port-write-timeout))
+
+(define port-write-timeout-error?
+  (record-predicate &port-write-timeout))
+
+(define* (with-fibers-port-timeouts thunk
+                                    #:key timeout
+                                    (read-timeout timeout)
+                                    (write-timeout timeout))
+  (define (no-fibers-wait port mode timeout)
+    (define poll-timeout-ms 200)
+
+    ;; When the GC runs, it restarts the poll syscall, but the timeout
+    ;; remains unchanged! When the timeout is longer than the time
+    ;; between the syscall restarting, I think this renders the
+    ;; timeout useless. Therefore, this code uses a short timeout, and
+    ;; repeatedly calls poll while watching the clock to see if it has
+    ;; timed out overall.
+    (let ((timeout-internal
+           (+ (get-internal-real-time)
+              (* internal-time-units-per-second
+                 (/ timeout 1000)))))
+      (let loop ((poll-value
+                  (port-poll port mode poll-timeout-ms)))
+        (if (= poll-value 0)
+            (if (> (get-internal-real-time)
+                   timeout-internal)
+                (raise-exception
+                 (if (string=? mode "r")
+                     (make-port-read-timeout-error port)
+                     (make-port-write-timeout-error port)))
+                (loop (port-poll port mode poll-timeout-ms)))
+            poll-value))))
+
+  (parameterize
+      ((current-read-waiter
+        (lambda (port)
+          (if (current-scheduler)
+              (perform-operation
+               (choice-operation
+                (wait-until-port-readable-operation port)
+                (wrap-operation
+                 (sleep-operation read-timeout)
+                 (lambda ()
+                   (raise-exception
+                    (make-port-read-timeout-error thunk port))))))
+              (no-fibers-wait port "r" read-timeout))))
+       (current-write-waiter
+        (lambda (port)
+          (if (current-scheduler)
+              (perform-operation
+               (choice-operation
+                (wait-until-port-writable-operation port)
+                (wrap-operation
+                 (sleep-operation write-timeout)
+                 (lambda ()
+                   (raise-exception
+                    (make-port-write-timeout-error thunk port))))))
+              (no-fibers-wait port "w" write-timeout)))))
+    (thunk)))