Restore history at launch; show real send errors with rate-limit details
ober
8917682524eea294f2f80fd0bbbd61c5661d6892
--- a/signal/tui/main.ss +++ b/signal/tui/main.ss @@ -14,6 +14,7 @@ partition make-date make-time) (except (jerboa prelude) meta atom?) + (std text json) (signal rpc-actor) (signal store) (signal logdb) @@ -56,8 +57,7 @@ (list (make-system-conversation (list - "TUI connected. Waiting for Signal receive notifications." - "Session history is in memory only."))) + "TUI connected. Waiting for Signal receive notifications."))) 0 'chat "" @@ -69,11 +69,12 @@ state (if logdb "Encrypted logging ON: messages are saved even if deleted later." - "Encrypted logging OFF.")) + "Encrypted logging OFF: history is session-only.")) (tb-hide-cursor!) (draw! state) (tb-present!) (seed-known-conversations! state actor) + (preload-history! state) (event-loop state actor)))) (lambda () (when logdb (logdb-close logdb)))))) @@ -93,6 +94,65 @@ (ensure-store-dir!) (logdb-open (messages-store-path acct) key)))))) + ;; 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 + ;; removed stay removed: their rows are skipped, never resurrected. + (def *history-preload-limit* 2000) + + (def (preload-history! state) + (let ([logdb (tui-state-logdb state)]) + (when logdb + (let loop ([rows (logdb-recent logdb *history-preload-limit*)] + [count 0]) + (cond + [(null? rows) + (when (> count 0) + (tui-state-status-set! + state + (string-append "Restored " + (number->string count) + " messages from the encrypted log.")))] + [else + (loop (cdr rows) + (+ count (if (apply-history-row! state (car rows)) 1 0)))]))))) + + ;; row = (direction conversation sender timestamp kind body); see logdb-recent. + (def (apply-history-row! state row) + (let* ([direction (list-ref row 0)] + [conv-id (list-ref row 1)] + [sender (list-ref row 2)] + [ts (list-ref row 3)] + [body (list-ref row 5)] + [kind-target (parse-conversation-id conv-id)]) + (and kind-target + (not (conversation-removed? state conv-id)) + (let* ([out? (string=? direction "out")] + [conv (ensure-conversation! state conv-id "" + (car kind-target) + (cdr kind-target))] + [msg (make-chat-message (if out? 'out 'in) + (if out? "You" sender) + body + (and (number? ts) (> ts 0) ts) + 'data + #f)]) + (append-message-to-conversation! conv msg) + #t)))) + + ;; "direct:<target>" / "group:<id>" -> (kind . target), #f for anything else. + (def (parse-conversation-id id) + (cond + [(id-prefix id "direct:") => (lambda (rest) (cons 'direct rest))] + [(id-prefix id "group:") => (lambda (rest) (cons 'group rest))] + [else #f])) + + (def (id-prefix id prefix) + (let ([plen (string-length prefix)]) + (and (> (string-length id) plen) + (string=? (substring id 0 plen) prefix) + (substring id plen (string-length id))))) + (def (event-loop state actor) (let loop () (handle-actor-events! state actor) @@ -768,7 +828,7 @@ (tui-state-input-set! state "") (tui-state-status-set! state "Sending...") (let ([outcome - (guard (e [#t (cons 'failed (safe-display e))]) + (guard (e [#t (cons 'failed e)]) (cons 'sent (actor-call actor "send" (make-send-params-for-conversation conv text))))]) (if (eq? (car outcome) 'sent) @@ -784,11 +844,8 @@ (tui-state-status-set! state "Sent.")) (begin (tui-state-resend-set! state text) - (tui-state-status-set! - state - (string-append "Send failed (it may still have gone out): " - (cdr outcome) - " -- Ctrl-R restores the message.")))))]))) + (report-send-failure! state conv (cdr outcome) + "Ctrl-R restores the message."))))]))) ;; Ctrl-R: put the last failed message back in the composer. Resending is a ;; deliberate two-step (restore, then Enter), never an accident. @@ -824,6 +881,104 @@ (hashtable-set! p "attachment" attachments)) p)) + ;; --- Send-failure reporting --- + ;; + ;; signal-cli buries the actionable part of a refusal -- how long to wait + ;; (retryAfterSeconds), the proof-challenge token a captcha submission + ;; needs -- inside the RPC error's data payload, which display-condition + ;; renders opaquely. Dig the payload back out of the condition, put the + ;; interesting fields on the status line, and keep a durable copy (plus the + ;; raw JSON) in the System view: the status line is one row and the next + ;; event overwrites it. + + (def *rpc-hint-keys* + '("retryAfterSeconds" "retryAfter" "token" "challenge" "options" + "captchaRequired")) + + (def (report-send-failure! state conv e retry-hint) + (let* ([base (string-append "Send to " + (safe-display (conversation-target conv)) + " failed (it may still have gone out): " + (safe-display e))] + [err (rpc-error-data e)] + [hints (if err (collect-rpc-hints err '()) '())]) + (append-system-message! state base) + (for-each + (lambda (hint) (append-system-message! state (string-append " " hint))) + hints) + (when err + (append-json-detail! state err)) + (tui-state-status-set! + state + (string-append base + (if (pair? hints) + (string-append " [" (join-strings hints "; ") "]") + "") + " -- " retry-hint)))) + + ;; actor-call raises (error 'actor-call <message> <error-object>) where the + ;; error object is the parsed JSON-RPC "error" member; fish it back out of + ;; the condition irritants. #f when the failure was not an RPC error. + (def (rpc-error-data e) + (guard (_ [#t #f]) + (and (condition? e) + (let loop ([xs (condition-irritants e)]) + (cond + [(not (pair? xs)) #f] + [(hashtable? (car xs)) (car xs)] + [else (loop (cdr xs))]))))) + + ;; Walk the error payload (hashtables and JSON lists, any depth) and pick + ;; out the fields worth showing. Shape varies across signal-cli versions, + ;; so scan generically instead of modeling it. + (def (collect-rpc-hints x acc) + (cond + [(hashtable? x) + (let-values ([(keys vals) (hashtable-entries x)]) + (let loop ([i 0] [acc acc]) + (if (>= i (vector-length keys)) + acc + (let ([k (vector-ref keys i)] + [v (vector-ref vals i)]) + (loop (+ i 1) + (if (and (string? k) + (member k *rpc-hint-keys*) + (not (hashtable? v))) + (cons (string-append k ": " (hint-value->string v)) acc) + (collect-rpc-hints v acc)))))))] + [(pair? x) + (collect-rpc-hints (car x) (collect-rpc-hints (cdr x) acc))] + [else acc])) + + (def (hint-value->string v) + (cond + [(string? v) v] + [(number? v) (number->string v)] + [(list? v) (join-strings (map hint-value->string v) "/")] + [else (safe-display v)])) + + (def (join-strings xs sep) + (cond + [(null? xs) ""] + [(null? (cdr xs)) (car xs)] + [else (string-append (car xs) sep (join-strings (cdr xs) sep))])) + + ;; Long tokens would be truncated by the one-line message renderer, so the + ;; raw payload goes into the System view chunked across several lines. + (def (append-json-detail! state err) + (let ([json (guard (_ [#t (safe-display err)]) + (json-object->string err))]) + (for-each (lambda (line) (append-system-message! state line)) + (chunk-string (string-append "detail: " json) 100)))) + + (def (chunk-string s n) + (let ([len (string-length s)]) + (let loop ([i 0] [acc '()]) + (if (>= i len) + (reverse acc) + (let ([end (min len (+ i n))]) + (loop end (cons (substring s i end) acc))))))) + ;; --- Attach a file (Ctrl-U) --- (def (open-attach! state) @@ -887,7 +1042,7 @@ (tui-state-picker-query-set! state "") (tui-state-status-set! state "Sending file...") (let ([outcome - (guard (e [#t (cons 'failed (safe-display e))]) + (guard (e [#t (cons 'failed e)]) (cons 'sent (actor-call actor "send" (make-send-params conv caption (list path)))))]) (if (eq? (car outcome) 'sent) @@ -901,11 +1056,8 @@ (conversation-id conv) label ts) (conversation-unread-set! conv 0) (tui-state-status-set! state "File sent.")) - (tui-state-status-set! - state - (string-append "Send failed (it may still have gone out): " - (cdr outcome) - " -- Ctrl-U to retry " path))))]))) + (report-send-failure! state conv (cdr outcome) + (string-append "Ctrl-U to retry " path))))]))) (def (attachment-label path caption) (let ([base (string-append "[file: " (path-basename path) "]")]) @@ -1074,9 +1226,9 @@ ;; --- Search across all conversations --- ;; - ;; Scans the in-memory messages of every conversation this session. There is - ;; no durable history yet, so this finds anything received or sent while the - ;; TUI has been open, across all channels at once. + ;; Scans the in-memory messages of every conversation: everything received + ;; or sent this session plus what preload-history! restored from the + ;; encrypted log, across all channels at once. (def *max-search-hits* 200) @@ -1328,7 +1480,7 @@ "Enter send Esc cancel")) (def (draw-search-page! state x y width height) - (draw-panel! x y width height "Search session history") + (draw-panel! x y width height "Search message history") (draw-text! (+ x 2) (+ y 2) 6 (fg-strong) (panel-bg) "Find:") (fill-rect! (+ x 8) (+ y 2) (max 1 (- width 10)) 1 (fg) (input-bg)) (draw-text! (+ x 9) (+ y 2) (max 1 (- width 12)) (fg-strong) (input-bg) @@ -1496,7 +1648,12 @@ [(string? x) x] [else (let ([p (open-output-string)]) - (display x p) + ;; display on a condition prints an opaque #<compound condition>; + ;; display-condition renders the actual message and irritants, which + ;; is what we want on the status line when an RPC call fails. + (if (condition? x) + (display-condition x p) + (display x p)) (get-output-string p))])) (def (last xs)