Make TUI sends non-blocking
ober
aecaaf8e116d399aac12181e98f1288f6c38289e
--- a/Makefile +++ b/Makefile @@ -89,6 +89,7 @@ run-tui: binary tui-shim test: binary native-test-stage $(JEXEC) tests/test-send-result.ss $(JEXEC) tests/test-rpc-demux.ss + $(JEXEC) tests/test-tui-send-async.ss $(JEXEC) tests/test-bounded-line.ss $(JEXEC) tests/test-logdb-jsqlite.ss $(JEXEC) tests/test-secret-input.ss --- a/signal/tui/main.ss +++ b/signal/tui/main.ss @@ -6,6 +6,7 @@ run-tui-terminal-with-logdb open-tui-message-log history-replay-snapshot + start-send-worker-with-call! notification->chat-event notification->line terminal-display) @@ -495,7 +496,7 @@ (let ([events (tui-state-send-events state)] [logdb (tui-state-logdb state)] [started (real-time)]) - (go + (start-tui-worker! (lambda () (let ([version (actor-call-result actor "version")] [subscription (receive-subscription-result @@ -510,6 +511,9 @@ version subscription groups contacts history)))))))) + (def (start-tui-worker! thunk) + (fork-thread thunk)) + (def (actor-call-result actor method) (guard (e [(condition? e) (cons 'failed e)]) (cons 'ok (actor-call actor method #f)))) @@ -1575,31 +1579,44 @@ (def (start-send-worker! state actor kind conv-id display-text resend-text params started retry-hint success-status) - (let ([events (tui-state-send-events state)]) - (go - (lambda () - (let* ([rpc-start (real-time)] - [outcome - (guard (e [(condition? e) - (trace-event! "tui-send-rpc-failed-detail" - (safe-display e)) - (trace-public-event! - "tui-send-rpc-failed" - (list (cons 'ms (- (real-time) rpc-start)) - (cons 'error-chars - (string-length (safe-display e))))) - (cons 'failed e)]) - (let ([result (actor-call actor "send" params)]) - (trace-public-event! - "tui-send-rpc-done" - (list (cons 'ms (- (real-time) rpc-start)))) - (ensure-send-result-success! result) - (cons 'sent result)))]) - (guard (_ [(condition? _) (void)]) - (chan-put! events - (list 'send-complete kind conv-id display-text - resend-text started outcome retry-hint - success-status)))))))) + (start-send-worker-with-call! + (tui-state-send-events state) + (lambda () (actor-call actor "send" params)) + kind + conv-id + display-text + resend-text + started + retry-hint + success-status)) + + (def (start-send-worker-with-call! events call-send kind conv-id display-text + resend-text started retry-hint + success-status) + (start-tui-worker! + (lambda () + (let* ([rpc-start (real-time)] + [outcome + (guard (e [(condition? e) + (trace-event! "tui-send-rpc-failed-detail" + (safe-display e)) + (trace-public-event! + "tui-send-rpc-failed" + (list (cons 'ms (- (real-time) rpc-start)) + (cons 'error-chars + (string-length (safe-display e))))) + (cons 'failed e)]) + (let ([result (call-send)]) + (trace-public-event! + "tui-send-rpc-done" + (list (cons 'ms (- (real-time) rpc-start)))) + (ensure-send-result-success! result) + (cons 'sent result)))]) + (guard (_ [(condition? _) (void)]) + (chan-put! events + (list 'send-complete kind conv-id display-text + resend-text started outcome retry-hint + success-status))))))) (def (make-send-params-for-conversation conv text) (make-send-params conv text '())) new file mode 100644 --- /dev/null +++ b/tests/test-tui-send-async.ss @@ -0,0 +1,79 @@ +#!chezscheme +;;; Focused test that TUI sends are dispatched off the UI thread. + +(import (except (scheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (except (jerboa prelude) meta atom?) + (std csp) + (signal tui main)) + +(def (check label pred) + (unless pred + (error 'test-tui-send-async label))) + +(def (ht . kvs) + (let ([h (make-hashtable equal-hash equal?)]) + (let loop ([xs kvs]) + (unless (null? xs) + (hashtable-set! h (car xs) (cadr xs)) + (loop (cddr xs)))) + h)) + +(def (await-event ch timeout-ms) + (let ([deadline (+ (real-time) timeout-ms)]) + (let loop () + (let ([ev (chan-try-get ch)]) + (cond + [ev ev] + [(>= (real-time) deadline) #f] + [else + (sleep-ms 20) + (loop)]))))) + +(def events (make-channel/buf 4)) +(def send-started (box #f)) +(def slow-result + (ht "timestamp" 1234 + "results" (list (ht "type" "SUCCESS")))) + +(let ([before (real-time)]) + (start-send-worker-with-call! + events + (lambda () + (set-box! send-started #t) + (sleep-ms 600) + slow-result) + 'message + "direct:+15550001" + "hello" + "hello" + before + "Ctrl-R restores the message." + "Sent.") + (check "worker starts asynchronously" + (< (- (real-time) before) 300)) + (check "slow send has not completed inline" + (not (chan-try-get events)))) + +(let ([ev (await-event events 2000)]) + (check "slow send ran" (unbox send-started)) + (check "completion event arrives" ev) + (check "event type is send-complete" + (eq? (car ev) 'send-complete)) + (check "event preserves conversation id" + (string=? (list-ref ev 2) "direct:+15550001")) + (check "event preserves display text" + (string=? (list-ref ev 3) "hello")) + (let ([outcome (list-ref ev 6)]) + (check "send result is successful" (eq? (car outcome) 'sent)) + (check "send result is preserved" (eq? (cdr outcome) slow-result)))) + +(display "tui send async ok") +(newline)