(define-module (guix-build-coordinator utils timeout)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 suspendable-ports)
  #:use-module ((ice-9 ports internal) #:select (port-poll))
  #:export (&port-timeout
            &port-read-timeout
            &port-write-timeout

            port-timeout-error?
            port-read-timeout-error?
            port-write-timeout-error?

            with-port-timeouts))

(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-port-timeouts thunk #:key timeout)

  ;; 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.
  (define poll-timeout-ms 200)

  (define (wait port mode)
    (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))))

  (parameterize
      ((current-read-waiter
        (lambda (port)
          (wait port "r")))
       (current-write-waiter
        (lambda (port)
          (wait port "w"))))
    (thunk)))