tee-output-port.rkt

#lang racket/base

(struct pending-tee (bstr out start end) #:authentic #:mutable)

(define (tee-output-port out1 out2)
  (define pending #f)
  (define lock (make-semaphore 1))

  ;(define ready-evt
  ;  (replace-evt lock (λ (_) (replace-evt out1 (λ (_) out2)))))
  
  (define ready-evt (replace-evt out1 (λ (_) out2)))
  (define retry-evt (handle-evt ready-evt (λ (_) #f)))

  (define (write-pending!)
    (when pending
      (define bstr  (pending-tee-bstr pending))
      (define out   (pending-tee-out pending))
      (define start (pending-tee-start pending))
      (define end   (pending-tee-end pending))

      (define n (write-bytes-avail* bstr out start end))

      (when n
        (cond
          [(= n (- end start))
           (set! pending #f)]
          [(> n 0)
           (set-pending-tee-start! pending (+ start n))]))))

  (define (write-out bstr start end non-blocking? enable-break?)
    (define result
      (call-with-semaphore
       lock
       (λ ()
         (write-pending!)
         
         (cond
           [pending       retry-evt]
           [(= start end) 0]
           [enable-break? (write-out* write-bytes-avail/enable-break bstr start end)]
           [else          (write-out* write-bytes-avail* bstr start end)]))
       (λ () retry-evt)))

    (when (eqv? result 0)
      (flush-output out1)
      (flush-output out2))

    result)

  (define (write-out* write-initial bstr start end)
    (define m (write-initial bstr out1 start end))

    (cond
      [(or (not m) (= m 0))
       retry-evt]
      [else
       (define n
         (or (write-bytes-avail* bstr out2 start (+ start m))
             0))

       (when (< n m)
         (set! pending (pending-tee bstr out2 (+ start n) (+ start m))))

       m]))

  (define (close)
    ;; I don't see a way around holding the lock while performing
    ;; this blocking write.
    (call-with-semaphore
     lock
     (λ ()
       (when pending
         (write-bytes (pending-tee-bstr pending)
                      (pending-tee-out pending)
                      (pending-tee-start pending)
                      (pending-tee-end pending))
         (set! pending #f))))
    (flush-output out1)
    (flush-output out2))
  
  (make-output-port
   'tee
   ready-evt
   write-out
   close))