Just use with-fibers-port-timeouts from the build coordinator

1 files changed, 2 insertions, 170 deletions

diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm
index d96db57..00e0ed7 100644
--- a/guix-qa-frontpage/utils.scm
+++ b/guix-qa-frontpage/utils.scm
@@ -17,173 +17,5 @@
 ;;; <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))))
-      (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))))
-
-  (unless read-timeout
-    (if timeout
-        (error "unset read-timeout")
-        (error "unset timeout")))
-  (unless write-timeout
-    (error "unset write-timeout"))
-
-  (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)))
+  #:use-module (guix-build-coordinator utils fibers)
+  #:re-export (with-fibers-port-timeouts))