Initial commit

2024-10-03 23:57:22 +00:00 · 2024-10-03 23:57:22 +00:00 · 55a1efa08f
commit 55a1efa08f
60 changed files with 5485 additions and 0 deletions
--- a/core/src/statusbar.sld
+++ b/core/src/statusbar.sld
@ -0,0 +1,167 @@
+(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))))