168 lines
7.5 KiB
Text
168 lines
7.5 KiB
Text
|
(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 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 data)))
|
||
|
|
((eqv? event 'write) (bypass-write (string->utf8 data)))
|
||
|
|
((eqv? event 'error) (error data))
|
||
|
|
((and (eqv? event 'activity-start) (eq? (list-ref data 3) 104)) (set! last-builds-activity-id (list-ref data 1)))
|
||
|
|
((and (eqv? event 'activity-start) (eq? (list-ref data 3) 105))
|
||
|
|
(set! build-activity-mapping
|
||
|
|
(mapping-set! build-activity-mapping (list-ref data 1)
|
||
|
|
(string-drop-while (vector-ref (list-ref data 5) 0) (lambda (f) (not (char=? f #\-)))))))
|
||
|
|
((eqv? event 'activity-start) (set! last-activity-start-id (list-ref data 1)) (set! last-activity-start (list-ref data 4)) (rerender-status-bar))
|
||
|
|
((eqv? event 'activity-stop)
|
||
|
|
(set! build-activity-mapping (mapping-delete! build-activity-mapping data)))
|
||
|
|
((and (eqv? event 'activity-result) (eqv? (list-ref data 2) 101))
|
||
|
|
(let ((drv-name (mapping-ref/default build-activity-mapping (list-ref data 1) #f)))
|
||
|
|
(when drv-name
|
||
|
|
(let ((msg (string-append drv-name "> " (vector-ref (list-ref data 3) 0))))
|
||
|
|
(mutex-lock! out-mutex)
|
||
|
|
(set! last-activity-start msg)
|
||
|
|
(set! last-activity-start-id (list-ref data 1))
|
||
|
|
(mutex-unlock! out-mutex)
|
||
|
|
(when print-logs
|
||
|
|
(bypass-write (string->utf8 msg)))))))
|
||
|
|
((and (eqv? event 'activity-result) (eqv? (list-ref data 1) last-builds-activity-id))
|
||
|
|
(set! last-builds-activity-data (list-ref data 3))
|
||
|
|
(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))))
|