fixes for hangs
ober
c4a0a7450a3efcd95dd5d95c94f91d5464d7dd9c
new file mode 100644 --- /dev/null +++ b/signal/account.ss @@ -0,0 +1,53 @@ +#!chezscheme +;;; signal/account -- resolve signal-cli account selection. + +(library (signal account) + (export resolve-signal-account) + + (import (except (chezscheme) + 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 text json)) + + (def (resolve-signal-account account) + (or account (single-local-account))) + + (def (single-local-account) + (guard (e [#t #f]) + (let* ([path (accounts-json-path)] + [obj (and (file-exists? path) + (string->json-object (read-file-string path)))] + [accounts (and (hashtable? obj) + (hash-ref obj "accounts" #f))]) + (and (list? accounts) + (not (null? accounts)) + (null? (cdr accounts)) + (account-number (car accounts)))))) + + (def (account-number account) + (and (hashtable? account) + (let ([number (hash-ref account "number" #f)]) + (and (string? number) + (not (string=? number "")) + number)))) + + (def (accounts-json-path) + (string-append (signal-cli-data-dir) "/data/accounts.json")) + + (def (signal-cli-data-dir) + (let ([xdg (getenv "XDG_DATA_HOME")]) + (if (and (string? xdg) (not (string=? xdg ""))) + (string-append xdg "/signal-cli") + (string-append (home) "/.local/share/signal-cli")))) + + (def (home) + (or (getenv "HOME") ".")) + + ) ;; end library --- a/signal/rpc-actor.ss +++ b/signal/rpc-actor.ss @@ -29,21 +29,25 @@ (except (jerboa prelude) meta atom?) (std csp) (std misc process) - (std text json)) + (std text json) + (signal account)) ;; proc : process-port-rec ;; next-id-box : box holding the next JSON-RPC id ;; pending : id -> response channel ;; lock : protects next-id-box, pending, closed-box, and stdin writes ;; events : non-blocking notification/error stream for the caller - ;; reader : reader thread handle + ;; reader : stdout reader thread handle + ;; stderr : stderr reader thread handle ;; closed-box : box boolean - (defstruct signal-actor (proc next-id-box pending lock events reader closed-box)) + (defstruct signal-actor + (proc next-id-box pending lock events reader stderr closed-box)) (def (start-signal-actor account . maybe-receive-mode) ;; Use manual receive mode by default. The future TUI can explicitly call ;; subscribeReceive when it is ready to route notifications into app state. - (let* ([receive-mode (if (pair? maybe-receive-mode) + (let* ([account (resolve-signal-account account)] + [receive-mode (if (pair? maybe-receive-mode) (car maybe-receive-mode) "manual")] [cmd (if account @@ -58,9 +62,13 @@ (make-mutex) (make-channel/sliding 1024) #f + #f (box #f))] - [reader (fork-thread (lambda () (actor-reader-loop actor)))]) + [reader (fork-thread (lambda () (actor-reader-loop actor)))] + [stderr-reader + (fork-thread (lambda () (actor-stderr-loop actor)))]) (signal-actor-reader-set! actor reader) + (signal-actor-stderr-set! actor stderr-reader) actor)) (def (signal-actor-pid actor) @@ -134,10 +142,32 @@ [(has-rpc-id? msg) (deliver-response! actor msg) (loop)] + [(bad-frame? msg) + (emit-event! + actor + (list 'error + (string-append "non-JSON output from signal-cli: " + (bad-frame-line msg)))) + (loop)] [else (emit-event! actor (list 'unknown msg)) (loop)])))))) + (def (actor-stderr-loop actor) + (guard (e [#t + (unless (signal-actor-closed? actor) + (emit-event! + actor + (list 'error + (string-append "signal-cli stderr reader failed: " + (condition->string e)))))]) + (let ([port (process-port-rec-stderr-port (signal-actor-proc actor))]) + (let loop () + (let ([line (get-line port)]) + (unless (eof-object? line) + (emit-event! actor (list 'stderr line)) + (loop))))))) + (def (mark-closed! actor reason) (with-actor-lock actor (lambda () @@ -225,7 +255,8 @@ [line (get-line port)]) (if (eof-object? line) line - (string->json-object line)))) + (guard (e [#t (make-bad-frame line)]) + (string->json-object line))))) (def (make-rpc-request id method params) (let ([h (make-hashtable equal-hash equal?)]) @@ -244,6 +275,15 @@ (not (hashtable-ref msg "id" #f)) (hashtable-ref msg "method" #f))) + (def (make-bad-frame line) + (cons 'bad-frame line)) + + (def (bad-frame? msg) + (and (pair? msg) (eq? (car msg) 'bad-frame))) + + (def (bad-frame-line msg) + (cdr msg)) + (def (rpc-response-result-or-raise msg) (let ([err (hashtable-ref msg "error" #f)]) (if err --- a/signal/rpc.ss +++ b/signal/rpc.ss @@ -29,7 +29,8 @@ make-date make-time) (except (jerboa prelude) meta atom?) (std misc process) - (std text json)) + (std text json) + (signal account)) ;; --- Process handle --- ;; proc : process-port-rec from (std misc process) @@ -39,12 +40,15 @@ (defstruct signal-cli (proc next-id-box pending notif-box)) (def (spawn-signal-cli account) - ;; Spawn `signal-cli [-a ACCOUNT] jsonRpc`. Pass #f for account if only - ;; one is linked. - (let* ([cmd (if account + ;; Spawn `signal-cli [-a ACCOUNT] jsonRpc`. When no account was provided + ;; and signal-cli has exactly one local account, pass it explicitly so the + ;; child does not enter multi-account JSON-RPC mode. + (let* ([account (resolve-signal-account account)] + [cmd (if account (list "signal-cli" "-a" account "jsonRpc") (list "signal-cli" "jsonRpc"))] [proc (open-process cmd)]) + (fork-thread (lambda () (drain-stderr-to-current-error-port proc))) (make-signal-cli proc (box 1) (make-hashtable equal-hash equal?) (box '())))) (def (signal-cli-pid sc) @@ -69,7 +73,19 @@ [line (get-line port)]) (if (eof-object? line) line - (string->json-object line)))) + (guard (e [#t (make-bad-frame line)]) + (string->json-object line))))) + + (def (drain-stderr-to-current-error-port proc) + (guard (e [#t (void)]) + (let ([port (process-port-rec-stderr-port proc)]) + (let loop () + (let ([line (get-line port)]) + (unless (eof-object? line) + (display "signal-cli: " (current-error-port)) + (display line (current-error-port)) + (newline (current-error-port)) + (loop))))))) ;; --- Request/response correlation --- @@ -97,6 +113,12 @@ (not (hashtable-ref msg "id" #f)) (hashtable-ref msg "method" #f))) + (def (make-bad-frame line) + (cons 'bad-frame line)) + + (def (bad-frame? msg) + (and (pair? msg) (eq? (car msg) 'bad-frame))) + (def (rpc-response-result-or-raise msg) (let ([err (hashtable-ref msg "error" #f)]) (if err @@ -126,6 +148,8 @@ [(rpc-notification? msg) (enqueue-notification! sc msg) (loop)] + [(bad-frame? msg) + (loop)] [else (loop)]))))) (def (next-notification sc) --- a/signal/tui/main.ss +++ b/signal/tui/main.ss @@ -215,6 +215,11 @@ state (string-append "signal-cli error: " (safe-display (cadr ev)))) (tui-state-status-set! state "signal-cli reported an error.")] + [(and (pair? ev) (eq? (car ev) 'stderr)) + (append-system-message! + state + (string-append "signal-cli: " (safe-display (cadr ev)))) + (tui-state-status-set! state "signal-cli reported a diagnostic.")] [else (void)])) events)))) @@ -1070,8 +1075,7 @@ (def (submit-captcha! state actor) (let ([challenge (tui-state-challenge state)] - [captcha (strip-captcha-scheme - (trim-spaces (tui-state-picker-query state)))]) + [captcha (trim-spaces (tui-state-picker-query state))]) (cond [(not challenge) (close-captcha! state) @@ -1106,11 +1110,6 @@ (hashtable-set! p "captcha" captcha) p)) - ;; The capture page hands back "signalcaptcha://<token>"; signal-cli wants - ;; the token, so drop the scheme when present. - (def (strip-captcha-scheme s) - (or (id-prefix s "signalcaptcha://") s)) - ;; --- Attach a file (Ctrl-U) --- (def (open-attach! state)