zilch/core/src/statusbar.sld

(define-library (zilch statusbar)
  (import
    (scheme base) (scheme write)
    (srfi 18) (srfi 128) (srfi 146) (srfi 151) (srfi 152)
    (chicken base) (chicken format) (chicken port) (chicken process signal)
    (zilch nix daemon)
    (zilch magic))

  (export
    statusbar-logger)

  (begin
    (define (buffered-port mutex write-output-line redraw-status-bar close-this-port)
      (define line-buffer (make-bytevector 1024 0))
      (define line-buffer-location 0)
      (define (append-to-buffer data start end)
          (when (>= (+ line-buffer-location (- end start)) (bytevector-length line-buffer))
            (let ((new-buffer (make-bytevector (* 2 (bytevector-length line-buffer)) 0)))
                 (bytevector-copy! new-buffer 0 line-buffer 0 line-buffer-location)
                 (set! line-buffer new-buffer)))
          (bytevector-copy! line-buffer line-buffer-location data start end)
          (set! line-buffer-location (+ line-buffer-location (- end start))))

      (define (write-data buf start)
        (define newline-location
          (do ((i start (+ i 1)))
              ((or (>= i (bytevector-length buf)) (= (bytevector-u8-ref buf i) #x0A))
               (if (>= i (bytevector-length buf)) #f i))))
        (if newline-location
          (begin
           (append-to-buffer buf start newline-location)
           (write-output-line line-buffer 0 line-buffer-location)
           (set! line-buffer-location 0)
           (write-data buf (+ 1 newline-location)))
          (begin
           (append-to-buffer buf start (bytevector-length buf))
           (when start
             (redraw-status-bar))
           (mutex-unlock! mutex))))
      (make-output-port (lambda (str) (mutex-lock! mutex) (write-data (string->utf8 str) 0)) close-this-port))

    (define (statusbar-logger out-port err-port print-logs)
      (define status-bar "[0/0 builds, 0 running] ...")
      (define terminal-width 80)
      (define-values (rows cols) (terminal-size err-port))
      (when (> cols 0) (set! terminal-width cols))

      (define (terminal-width-thread-thunk handler)
        (handler #t)
        (mutex-lock! out-mutex)
        (define-values (rows cols) (terminal-size err-port))
        (when (> cols 0) (set! terminal-width cols))
        (mutex-unlock! out-mutex)
        (terminal-width-thread-thunk handler))
      (define terminal-width-thread (make-thread (lambda () (terminal-width-thread-thunk (make-signal-handler signal/winch)))))

      (define (draw-status-bar)
        (fprintf err-port "\r\x1B[2K") ; ]
        (if (<= (string-length status-bar) terminal-width)
          (write-string status-bar err-port)
          (begin
            (write-string status-bar err-port 0 (- terminal-width 3))
            (write-string "..." err-port)))
        (flush-output-port err-port)
        (set! need-redraw #f))
       
      (define out-mutex (make-mutex))
      (define need-redraw #f)
      (define rerender-status-bar #f)
      (define (redraw-thread-thunk)
        (rerender-status-bar)
        (mutex-lock! out-mutex)
        (draw-status-bar)
        (mutex-unlock! out-mutex)
        (thread-sleep! 0.1)
        (redraw-thread-thunk))
      (define redraw-thread (make-thread redraw-thread-thunk "redraw thread"))

      (define last-builds-activity-id #f)
      (define last-builds-activity-data (vector 0 0 0 0))
      (define last-activity-start-id #f)
      (define last-activity-start "")

      (define (write-err-line buf start end)
        (if print-logs
          (begin
            (unless need-redraw
              (fprintf err-port "\r\x1B[2K")) ; ]
            (write-bytevector buf err-port start end)
            (fprintf err-port "\n")
            (set! need-redraw #t))
          (begin
            (set! last-activity-start-id #f)
            (set! last-activity-start (utf8->string (bytevector-copy buf start end)))
            (set! need-redraw #t))))

      (define (write-out-line buf start end)
        (unless need-redraw
          (fprintf err-port "\r\x1B[2K")) ; ]
        (flush-output-port err-port)
        (write-bytevector buf out-port start end)
        (fprintf out-port "\n")
        (set! need-redraw #t))

      (define (bypass-write buf)
        (mutex-lock! out-mutex)
        (write-err-line buf 0 (bytevector-length buf))
        (draw-status-bar)
        (set! need-redraw #f)
        (mutex-unlock! out-mutex))
       
      (define (close-this-port)
         (mutex-lock! out-mutex)
         (thread-terminate! redraw-thread)
         (thread-terminate! terminal-width-thread)
         (mutex-unlock! out-mutex)
         (fprintf err-port "\r\x1B[2K\n")
         (close-output-port err-port)
         (close-output-port out-port))

      (define new-err-port (buffered-port out-mutex write-err-line draw-status-bar close-this-port))
      (define new-out-port (buffered-port out-mutex write-out-line draw-status-bar close-this-port))
      (on-exit close-this-port)

      (define build-activity-mapping (mapping (make-default-comparator)))
      (set! rerender-status-bar
        (lambda ()
          (mutex-lock! out-mutex)
          (set! status-bar (sprintf "[~S drv  ~S bld  ~S ifd | nix: ~S/~S builds, ~S running] ~A"
                                    (vector-ref zilch-magic-counters 0)
                                    (vector-ref zilch-magic-counters 1)
                                    (vector-ref zilch-magic-counters 2)
                                    (vector-ref last-builds-activity-data 0)
                                    (vector-ref last-builds-activity-data 1)
                                    (vector-ref last-builds-activity-data 2)
                                    last-activity-start))
          (set! need-redraw #t)
          (mutex-unlock! out-mutex)))
      (define (handle-log-event event data)
       (cond
        ((eqv? event 'next) (bypass-write (string->utf8 (string-copy data 0 (- (string-length data) 1)))))
        ((eqv? event 'write) (bypass-write (string->utf8 data))) ; TODO(puck): is this ever called?
        ((eqv? event 'error) (error data))
        ((and (eqv? event 'activity-start) (eq? (nix-activity-type data) 104)) (set! last-builds-activity-id (nix-activity-id data)))
        ((and (eqv? event 'activity-start) (eq? (nix-activity-type data) 105))
         (set! build-activity-mapping
           (mapping-set! build-activity-mapping (nix-activity-id data)
             (string-drop (string-drop-while (vector-ref (nix-activity-fields data) 0) (lambda (f) (not (char=? f #\-)))) 1))))
        ((eqv? event 'activity-start) (set! last-activity-start-id (nix-activity-id data)) (set! last-activity-start (nix-activity-string data)) (rerender-status-bar))
        ((eqv? event 'activity-stop)
         (set! build-activity-mapping (mapping-delete! build-activity-mapping data)))
        ((and (eqv? event 'activity-result) (eqv? (nix-activity-type data) 101))
         (let ((drv-name (mapping-ref/default build-activity-mapping (nix-activity-id data) #f)))
              (when drv-name
                (let ((msg (string-append drv-name "> " (vector-ref (nix-activity-fields data) 0))))
                  (mutex-lock! out-mutex)
                  (set! last-activity-start msg)
                  (set! last-activity-start-id (nix-activity-id data))
                  (mutex-unlock! out-mutex)
                  (when print-logs
                    (bypass-write (string->utf8 msg)))))))
        ((and (eqv? event 'activity-result) (eqv? (nix-activity-id data) last-builds-activity-id))
         (set! last-builds-activity-data (nix-activity-fields data))
         (rerender-status-bar))))
      (thread-start! redraw-thread)
      (thread-start! terminal-width-thread)
      (define (set-print-logs val) (set! print-logs val))
      (values new-out-port new-err-port set-print-logs handle-log-event))))