fix hangs
ober
4f2f964892c70cd06d96944682be109ad3330163
--- a/signal/cmd-tui.ss +++ b/signal/cmd-tui.ss @@ -40,15 +40,7 @@ (display "jerboa-signal: starting Signal backend...\n") (flush-output-port (current-output-port)) (set! actor (start-signal-actor account receive-mode)) - (let* ([version-result (actor-call actor "version" #f)] - [version (if (hashtable? version-result) - (hashtable-ref version-result "version" "unknown") - "unknown")]) - ;; signal-cli's JSON-RPC manual recommends manual receive + - ;; subscribeReceive when embedding, so no receive starts before - ;; the app reader is ready to demultiplex notifications. - (actor-call actor "subscribeReceive" #f) - (run-tui-terminal-with-logdb account actor version receive-mode logdb))) + (run-tui-terminal-with-logdb account actor "loading" receive-mode logdb)) (lambda () (when actor (stop-signal-actor actor)) (when logdb (logdb-close logdb)))))) --- a/signal/logdb.ss +++ b/signal/logdb.ss @@ -27,7 +27,7 @@ (only (jerboa ffi) load-shared-object*) (std os path) (only (std security taint) - safe-delete-file safe-open-output-file safe-system) + safe-delete-file safe-system) (jsqlite api) (jsqlite value) (signal log_crypto) @@ -203,7 +203,7 @@ (guard (e [(condition? e) (when p (close-port p)) (raise e)]) - (set! p (safe-open-output-file safe-path)) + (set! p (open-file-output-port safe-path (file-options no-fail))) (put-bytevector p bv) (close-port p) (set! p #f) @@ -216,12 +216,27 @@ (def (write-file-atomic! path bv) (let* ([safe-path (checked-log-path path)] - [safe-tmp-path (checked-log-path (string-append safe-path ".tmp"))]) - (delete-if-exists! safe-tmp-path) - (write-file-bytevector! safe-tmp-path bv) - (when (file-exists? safe-path) - (safe-delete-file safe-path)) - (rename-file safe-tmp-path safe-path))) + [safe-tmp-path (unique-temp-log-path safe-path)]) + (guard (e [(condition? e) + (when (file-exists? safe-tmp-path) + (guard (_ [(condition? _) (void)]) + (safe-delete-file safe-tmp-path))) + (raise e)]) + (write-file-bytevector! safe-tmp-path bv) + (rename-file safe-tmp-path safe-path)))) + + (def (unique-temp-log-path safe-path) + (let ([prefix (string-append safe-path + ".tmp." + (number->string (real-time)) + ".")]) + (let loop ([n 0]) + (let ([candidate + (checked-log-path + (string-append prefix (number->string n)))]) + (if (file-exists? candidate) + (loop (+ n 1)) + candidate))))) (def (checked-log-path path) (unless (and (string? path) @@ -628,9 +643,6 @@ [else (or (open-jlog path key) (wrap-legacy (legacy-open path key)))])]) - (when (and (logdb-handle? handle) - (eq? (logdb-handle-backend handle) 'jsqlite)) - (jlog-begin-close-transaction! (logdb-handle-inner handle))) (trace-public-event! "logdb-open-done" (list (cons 'path path) --- a/signal/tui/ffi.ss +++ b/signal/tui/ffi.ss @@ -25,7 +25,7 @@ TB_KEY_CTRL_Y TB_MOD_ALT TB_MOD_CTRL TB_MOD_SHIFT TB_INPUT_ESC TB_INPUT_MOUSE - TB_OUTPUT_TRUECOLOR + TB_OUTPUT_NORMAL TB_OUTPUT_256 TB_OUTPUT_TRUECOLOR TB_DEFAULT TB_BLACK TB_RED TB_GREEN TB_YELLOW TB_BLUE TB_MAGENTA TB_CYAN TB_WHITE TB_BOLD TB_UNDERLINE TB_REVERSE TB_ITALIC TB_DIM) @@ -186,6 +186,8 @@ (def TB_INPUT_ESC 1) (def TB_INPUT_MOUSE 4) + (def TB_OUTPUT_NORMAL 1) + (def TB_OUTPUT_256 2) (def TB_OUTPUT_TRUECOLOR 5) (def TB_DEFAULT #x0000) --- a/signal/tui/main.ss +++ b/signal/tui/main.ss @@ -46,7 +46,7 @@ (defstruct tui-state (account version receive-mode width height input status quit? event-count conversations selected-index mode picker-query picker-index removed aliases - logdb resend challenge rate-limits send-events)) + logdb live-capture? resend challenge rate-limits send-events)) (def (run-tui-terminal account actor version receive-mode) ;; Prompt for the log passphrase and open the DB BEFORE termbox grabs the @@ -67,7 +67,7 @@ [removed (load-removed-set acct)]) (with-tui (tb-set-input-mode! (bitwise-ior TB_INPUT_ESC TB_INPUT_MOUSE)) - (tb-set-output-mode! TB_OUTPUT_TRUECOLOR) + (configure-tui-output!) ;; Load any user opencode JSON themes, then apply the saved theme ;; (or the opencode-dark default), falling back if the saved name ;; is no longer registered. @@ -85,15 +85,69 @@ (append-system-message! state (if logdb - "Encrypted logging ON: messages are saved even if deleted later." + (if (tui-state-live-capture? state) + "Encrypted logging ON: live TUI messages are saved." + "Encrypted history ON: live TUI capture is off for responsiveness.") "Encrypted logging OFF: history is session-only.")) (tb-hide-cursor!) (draw! state) (tb-present!) - (seed-known-conversations! state actor) - (preload-history! state) + (start-startup-worker! state actor) (event-loop state actor))))) + (def (configure-tui-output!) + (let ([mode (preferred-tui-output-mode)]) + (set-theme-color-mode! mode) + (tb-set-output-mode! + (cond + [(eq? mode 'normal) TB_OUTPUT_NORMAL] + [(eq? mode '256) TB_OUTPUT_256] + [else TB_OUTPUT_TRUECOLOR])))) + + (def (preferred-tui-output-mode) + (let ([override (getenv "JERBOA_SIGNAL_TUI_OUTPUT")]) + (cond + [(non-empty-string? override) + (parse-tui-output-mode override)] + [(terminal-mux?) (if (terminal-256color?) '256 'normal)] + [else 'truecolor]))) + + (def (parse-tui-output-mode raw) + (let ([s (ascii-downcase raw)]) + (cond + [(or (string=? s "normal") + (string=? s "basic") + (string=? s "8") + (string=? s "8color") + (string=? s "8-color")) + 'normal] + [(or (string=? s "256") + (string=? s "256color") + (string=? s "256-color")) + '256] + [else 'truecolor]))) + + (def (terminal-mux?) + (or (non-empty-string? (getenv "TMUX")) + (non-empty-string? (getenv "STY")) + (non-empty-string? (getenv "ZELLIJ")) + (let ([term (ascii-downcase (or (getenv "TERM") ""))]) + (or (string-contains? term "tmux") + (string-contains? term "screen"))))) + + (def (terminal-256color?) + (let ([term (ascii-downcase (or (getenv "TERM") ""))]) + (string-contains? term "256color"))) + + (def (tui-live-capture-enabled?) + (let ([v (or (getenv "JERBOA_SIGNAL_TUI_CAPTURE") + (getenv "JERBOA_SIGNAL_TUI_LIVE_LOG"))]) + (and (string? v) + (or (string-ci=? v "1") + (string-ci=? v "on") + (string-ci=? v "true") + (string-ci=? v "yes"))))) + (def (make-initial-tui-state acct version receive-mode width height logdb removed) (make-tui-state acct version @@ -115,6 +169,7 @@ removed (make-hashtable equal-hash equal?) logdb + (tui-live-capture-enabled?) #f #f (make-hashtable equal-hash equal?) @@ -124,6 +179,7 @@ ;; if set (enables headless use), otherwise we prompt. A blank passphrase or a ;; missing shim disables logging and the TUI runs normally. (def (open-tui-message-log acct) + (ensure-tui-log-persist-default!) (and (logdb-available?) (let* ([env (getenv "JERBOA_SIGNAL_DB_KEY")] [key (if (and env (not (string=? env ""))) @@ -136,6 +192,11 @@ (ensure-store-dir!) (logdb-open (messages-store-path acct) key)))))) + (def (ensure-tui-log-persist-default!) + (let ([v (getenv "JERBOA_SIGNAL_LOG_PERSIST")]) + (unless (and (string? v) (not (string=? v ""))) + (putenv "JERBOA_SIGNAL_LOG_PERSIST" "close")))) + ;; Pull recent rows out of the encrypted log so search and scrollback cover ;; previous sessions, not just this one. Runs after contact/group seeding so ;; restored conversations keep their proper titles. Conversations the user @@ -315,6 +376,7 @@ cur))) (def *idle-poll-ms* 250) + (def *max-actor-events-per-tick* 32) (def (event-loop state actor) (let loop ([dirty? #t]) @@ -343,7 +405,7 @@ (loop (cdr convs) (or changed? expired?)))])))) (def (handle-actor-events! state actor) - (let ([events (actor-drain-events actor)]) + (let ([events (actor-take-events actor *max-actor-events-per-tick*)]) (if (null? events) #f (begin @@ -356,9 +418,11 @@ [(and (pair? ev) (eq? (car ev) 'notification)) (let* ([notif (cadr ev)] [chat-event (notification->chat-event notif)]) - (capture-notification! (tui-state-logdb state) - (tui-state-account state) - notif) + (when (and (tui-state-live-capture? state) + (loggable-chat-event? chat-event)) + (capture-notification! (tui-state-logdb state) + (tui-state-account state) + notif)) (if chat-event (apply-chat-event! state chat-event) (let ([line (notification->line notif)]) @@ -393,6 +457,18 @@ events) #t)))) + (def (loggable-chat-event? chat-event) + (and (pair? chat-event) (eq? (car chat-event) 'message))) + + (def (actor-take-events actor max-events) + (let loop ([remaining max-events] [acc '()]) + (if (<= remaining 0) + (reverse acc) + (let ([ev (actor-try-event actor)]) + (if ev + (loop (- remaining 1) (cons ev acc)) + (reverse acc)))))) + (def (handle-send-events! state) (let loop ([dirty? #f]) (let ([ev (chan-try-get (tui-state-send-events state))]) @@ -404,10 +480,148 @@ (def (handle-send-event! state ev) (cond + [(and (pair? ev) (eq? (car ev) 'startup-complete)) + (handle-startup-complete! state ev)] [(and (pair? ev) (eq? (car ev) 'send-complete)) (handle-send-complete! state ev)] [else (void)])) + (def (start-startup-worker! state actor) + (tui-state-status-set! + state + "Loading contacts, groups, and encrypted history...") + (let ([events (tui-state-send-events state)] + [logdb (tui-state-logdb state)] + [started (real-time)]) + (go + (lambda () + (let ([version (actor-call-result actor "version")] + [subscription (actor-call-result actor "subscribeReceive")] + [groups (actor-list-result actor "listGroups" "groups")] + [contacts (actor-list-result actor "listContacts" "contacts")] + [history (history-rows-result logdb)]) + (guard (_ [(condition? _) (void)]) + (chan-put! events + (list 'startup-complete started + version subscription + groups contacts history)))))))) + + (def (actor-call-result actor method) + (guard (e [(condition? e) (cons 'failed e)]) + (cons 'ok (actor-call actor method #f)))) + + (def (actor-list-result actor method label) + (let ([call (actor-call-result actor method)]) + (if (and (pair? call) (eq? (car call) 'ok)) + (let ([result (cdr call)]) + (if (list? result) + (cons 'ok result) + (cons 'failed + (string-append "Unexpected " label + " response from signal-cli.")))) + call))) + + (def (history-rows-result logdb) + (if logdb + (let ([started (real-time)]) + (trace-public-event! + "tui-history-preload-start" + (list (cons 'limit *history-preload-limit*))) + (guard (e [(condition? e) (cons 'failed e)]) + (let ([rows (logdb-recent logdb *history-preload-limit*)]) + (trace-public-event! + "tui-history-preload-read-done" + (list (cons 'rows (length rows)) + (cons 'ms (- (real-time) started)))) + (cons 'ok rows)))) + (cons 'ok '()))) + + (def (handle-startup-complete! state ev) + (let* ([started (list-ref ev 1)] + [version (list-ref ev 2)] + [subscription (list-ref ev 3)] + [groups (list-ref ev 4)] + [contacts (list-ref ev 5)] + [history (list-ref ev 6)] + [_ (apply-version-result! state version)] + [subscribed? (apply-subscription-result! state subscription)] + [group-count (apply-list-result! state groups seed-group-list! + "groups")] + [contact-count (apply-list-result! state contacts seed-contact-list! + "contacts")] + [history-count (apply-history-result! state history)]) + (trace-public-event! + "tui-startup-load-done" + (list (cons 'groups group-count) + (cons 'contacts contact-count) + (cons 'history history-count) + (cons 'subscribed subscribed?) + (cons 'ms (- (real-time) started)))) + (tui-state-status-set! + state + (string-append "Loaded " + (number->string contact-count) + " contacts, " + (number->string group-count) + " groups, " + (number->string history-count) + " history messages" + (if subscribed? "." "; receive subscription failed."))))) + + (def (apply-version-result! state result) + (if (and (pair? result) (eq? (car result) 'ok) (hashtable? (cdr result))) + (let ([version (hashtable-ref (cdr result) "version" "unknown")]) + (tui-state-version-set! state version) + version) + (begin + (tui-state-version-set! state "unknown") + (append-system-message! + state + (string-append "Could not read signal-cli version: " + (safe-display (and (pair? result) (cdr result))))) + "unknown"))) + + (def (apply-subscription-result! state result) + (if (and (pair? result) (eq? (car result) 'ok)) + #t + (begin + (append-system-message! + state + (string-append "Could not subscribe to Signal receive events: " + (safe-display (and (pair? result) (cdr result))))) + #f))) + + (def (apply-list-result! state result handler label) + (if (and (pair? result) (eq? (car result) 'ok)) + (handler state (cdr result)) + (begin + (append-system-message! + state + (string-append "Could not load " + label + ": " + (safe-display (and (pair? result) (cdr result))))) + 0))) + + (def (apply-history-result! state result) + (if (and (pair? result) (eq? (car result) 'ok)) + (let loop ([rows (cdr result)] [count 0]) + (cond + [(null? rows) + (trace-public-event! + "tui-history-preload-done" + (list (cons 'restored count))) + count] + [else + (loop (cdr rows) + (+ count (if (apply-history-row! state (car rows)) 1 0)))])) + (begin + (append-system-message! + state + (string-append "Could not replay encrypted history: " + (safe-display (and (pair? result) (cdr result))))) + 0))) + (def (handle-send-complete! state ev) (let* ([kind (list-ref ev 1)] [conv-id (list-ref ev 2)] @@ -435,13 +649,14 @@ (make-chat-message 'out "You" display-text ts 'data 'sent)) (clear-conversation-rate-limit! state conv) (conversation-unread-set! conv 0)) - (let ([capture-start (real-time)]) - (capture-outbound! (tui-state-logdb state) - (tui-state-account state) - conv-id display-text ts) - (trace-public-event! - "tui-send-capture-done" - (list (cons 'ms (- (real-time) capture-start))))) + (when (tui-state-live-capture? state) + (let ([capture-start (real-time)]) + (capture-outbound! (tui-state-logdb state) + (tui-state-account state) + conv-id display-text ts) + (trace-public-event! + "tui-send-capture-done" + (list (cons 'ms (- (real-time) capture-start)))))) (when (eq? kind 'message) (tui-state-resend-set! state #f)) (trace-public-event! @@ -488,11 +703,11 @@ (def (append-message-to-conversation! conv msg) (let* ([messages (conversation-messages conv)] - [next (append messages (list msg))] - [trimmed (if (> (length next) 200) - (drop-oldest next (- (length next) 200)) - next)]) - (conversation-messages-set! conv trimmed))) + [len (length messages)] + [base (if (>= len 200) + (drop-oldest messages (- len 199)) + messages)]) + (conversation-messages-set! conv (append base (list msg))))) (def (apply-chat-event! state chat-event) (cond @@ -1258,7 +1473,9 @@ (trace-public-event! "tui-send-start" (list (cons 'text-chars (string-length text)) - (cons 'has-logdb (and (tui-state-logdb state) #t)))) + (cons 'has-logdb (and (tui-state-logdb state) #t)) + (cons 'live-capture + (tui-state-live-capture? state)))) ;; Clear the composer BEFORE the call: once the request is written to ;; signal-cli the message may be delivered even if the RPC reply is an ;; error (partial/multi-device failures), so Enter must never re-fire @@ -2218,13 +2435,15 @@ (draw-vline! (+ x width -1) y height (fg-dim) (panel-bg))) (def (draw-conversations! state x y width height) - (let loop ([conversations (tui-state-conversations state)] - [idx 0] - [row y]) - (when (and (pair? conversations) (< row (+ y height))) + (let* ([conversations (tui-state-conversations state)] + [selected-index (clamp-index (tui-state-selected-index state) + (length conversations))]) + (let loop ([conversations conversations] + [idx 0] + [row y]) + (when (and (pair? conversations) (< row (+ y height))) (let* ([conv (car conversations)] - [selected? (= idx (clamp-index (tui-state-selected-index state) - (length (tui-state-conversations state))))] + [selected? (= idx selected-index)] [marker (if selected? "> " " ")] [unread (conversation-unread conv)] [suffix (if (> unread 0) @@ -2236,7 +2455,7 @@ (string-append marker (conversation-title conv) suffix)) - (loop (cdr conversations) (+ idx 1) (+ row 1)))))) + (loop (cdr conversations) (+ idx 1) (+ row 1))))))) (def (draw-new-message-page! state x y width height) (draw-panel! x y width height "New Message") @@ -2433,13 +2652,13 @@ (def (thread-render-rows messages width rows) (if (<= rows 0) '() - (last-n-items - (let loop ([ms messages] [acc '()]) - (if (null? ms) - acc - (loop (cdr ms) - (append acc (message-render-rows (car ms) width))))) - rows))) + (let loop ([ms (reverse messages)] [acc '()]) + (cond + [(or (null? ms) (>= (length acc) rows)) + (last-n-items acc rows)] + [else + (loop (cdr ms) + (append (message-render-rows (car ms) width) acc))])))) (def (message-render-rows msg width) (let loop ([lines (chat-message->display-lines msg width)] [acc '()]) @@ -2506,19 +2725,16 @@ (tb-set-cursor! cursor-x (+ composer-y 1)))])) (def (fill-rect! x y width height fg bg) - (let yloop ([row y]) - (when (< row (+ y height)) - (let xloop ([col x]) - (when (< col (+ x width)) - (tb-change-cell! col row (char->integer #\space) fg bg) - (xloop (+ col 1)))) - (yloop (+ row 1))))) + (when (and (> width 0) (> height 0)) + (let ([line (make-string width #\space)]) + (let loop ([row y]) + (when (< row (+ y height)) + (tb-print! x row fg bg line) + (loop (+ row 1))))))) (def (draw-hline! x y width fg bg) - (let loop ([col x]) - (when (< col (+ x width)) - (tb-change-cell! col y (char->integer #\-) fg bg) - (loop (+ col 1))))) + (when (> width 0) + (tb-print! x y fg bg (make-string width #\-)))) (def (draw-vline! x y height fg bg) (let loop ([row y]) --- a/signal/tui/theme.ss +++ b/signal/tui/theme.ss @@ -12,6 +12,7 @@ (export make-face face? face-fg face-bg face-bold? face-italic? face-underline? current-theme current-theme-name set-theme-by-name! + set-theme-color-mode! face-ref face-fg-attr face-bg-attr register-theme! get-registered-themes cycle-theme-by-name! load-theme-json! load-themes-from-dir! @@ -49,8 +50,11 @@ (def *current-theme* (make-parameter #f)) (def *current-theme-name* (make-parameter #f)) + (def *theme-color-mode* (make-parameter 'truecolor)) (def (current-theme) (*current-theme*)) (def (current-theme-name) (*current-theme-name*)) + (def (set-theme-color-mode! mode) + (*theme-color-mode* mode)) (def (set-theme-by-name! name) (let ([theme (hashtable-ref *theme-registry* name #f)]) @@ -68,14 +72,69 @@ (def (face-fg-attr name) (let* ([f (face-ref name)] - [c (face-fg f)] + [c (theme-output-color (face-fg f))] [c (if (face-bold? f) (bitwise-ior c TB_BOLD) c)] [c (if (face-italic? f) (bitwise-ior c TB_ITALIC) c)] [c (if (face-underline? f) (bitwise-ior c TB_UNDERLINE) c)]) c)) (def (face-bg-attr name) - (face-bg (face-ref name))) + (theme-output-color (face-bg (face-ref name)))) + + (def (theme-output-color color) + (cond + [(or (not (number? color)) (= color TB_DEFAULT)) TB_DEFAULT] + [(eq? (*theme-color-mode*) 'normal) (rgb->normal-color color)] + [(eq? (*theme-color-mode*) '256) (rgb->256-color color)] + [else color])) + + (def (rgb->256-color color) + (let* ([r (color-channel color 16)] + [g (color-channel color 8)] + [b (color-channel color 0)] + [ri (rgb->xterm-level r)] + [gi (rgb->xterm-level g)] + [bi (rgb->xterm-level b)]) + (+ 16 (* 36 ri) (* 6 gi) bi))) + + (def (rgb->xterm-level channel) + (quotient (+ (* channel 5) 127) 255)) + + (def *normal-color-palette* + `((,TB_BLACK . (#x00 #x00 #x00)) + (,TB_RED . (#xcd #x31 #x31)) + (,TB_GREEN . (#x0d #xbc #x79)) + (,TB_YELLOW . (#xe5 #xe5 #x10)) + (,TB_BLUE . (#x24 #x71 #xa3)) + (,TB_MAGENTA . (#xbc #x3f #xbc)) + (,TB_CYAN . (#x11 #xa8 #xcd)) + (,TB_WHITE . (#xe5 #xe5 #xe5)))) + + (def (rgb->normal-color color) + (let ([r (color-channel color 16)] + [g (color-channel color 8)] + [b (color-channel color 0)]) + (let loop ([xs *normal-color-palette*] + [best-color TB_WHITE] + [best-distance #f]) + (if (null? xs) + best-color + (let* ([entry (car xs)] + [palette (cdr entry)] + [distance (color-distance r g b + (list-ref palette 0) + (list-ref palette 1) + (list-ref palette 2))]) + (if (or (not best-distance) (< distance best-distance)) + (loop (cdr xs) (car entry) distance) + (loop (cdr xs) best-color best-distance))))))) + + (def (color-distance r1 g1 b1 r2 g2 b2) + (+ (squared (- r1 r2)) + (squared (- g1 g2)) + (squared (- b1 b2)))) + + (def (squared n) (* n n)) ;; ---- Theme registry ---- --- a/tests/test-logdb-jsqlite.ss +++ b/tests/test-logdb-jsqlite.ss @@ -25,6 +25,11 @@ (close-port in) (if (eof-object? bv) (make-bytevector 0 0) bv)))) +(def (write-stale-file! p) + (call-with-output-file p + (lambda (out) + (display "stale temp" out)))) + (def (check label pred) (unless pred (error 'test-logdb-jsqlite label))) @@ -83,6 +88,28 @@ (delete-if-exists! path) (delete-if-exists! (string-append path ".tmp")) +(write-stale-file! (string-append path ".tmp")) +(putenv "JERBOA_SIGNAL_LOG_PERSIST" "close") + +(let ([h (logdb-open path "close horse")]) + (check "open close-mode log with stale tmp" h) + (check "close-mode put" + (logdb-put h "acct" "out" "direct:+15550002" "Me" + 2000 "data" "deferred" "{\"ok\":true}")) + (check "close-mode count before close" (= (logdb-count h) 1)) + (logdb-close h)) + +(let ([h (logdb-open path "close horse")]) + (check "close-mode persisted despite stale tmp" h) + (check "close-mode count after reopen" (= (logdb-count h) 1)) + (check "close-mode recent after reopen" + (equal? (logdb-recent h 10) + (list (list "out" "direct:+15550002" "Me" + 2000 "data" "deferred")))) + (logdb-close h)) + +(delete-if-exists! path) +(delete-if-exists! (string-append path ".tmp")) (display "logdb jsqlite smoke ok") (newline)