Show typing indicators and delivery/read receipts in the TUI
ober
acf29f6ec365111cc4454b4dbd1531bd0eff8956
--- a/signal/tui/main.ss +++ b/signal/tui/main.ss @@ -20,8 +20,8 @@ (signal capture) (signal tui ffi)) - (defstruct chat-message (direction sender text timestamp kind)) - (defstruct conversation (id title kind target messages unread)) + (defstruct chat-message (direction sender text timestamp kind status)) + (defstruct conversation (id title kind target messages unread typing)) (defstruct search-hit (conv-id conv-title message)) (defstruct tui-state (account version receive-mode width height input status quit? event-count @@ -114,9 +114,7 @@ (tui-state-account state) notif) (if chat-event - (begin - (apply-chat-event! state chat-event) - (tui-state-status-set! state "New Signal message received.")) + (apply-chat-event! state chat-event) (let ([line (notification->line notif)]) (when line (append-system-message! state line) @@ -140,15 +138,16 @@ 'system #f (map (lambda (line) - (make-chat-message 'system "system" line #f 'system)) + (make-chat-message 'system "system" line #f 'system #f)) lines) - 0)) + 0 + #f)) (def (append-system-message! state line) (let ([conv (ensure-conversation! state "system" "System" 'system #f)]) (append-message-to-conversation! conv - (make-chat-message 'system "system" line #f 'system)))) + (make-chat-message 'system "system" line #f 'system #f)))) (def (append-message-to-conversation! conv msg) (let* ([messages (conversation-messages conv)] @@ -159,15 +158,81 @@ (conversation-messages-set! conv trimmed))) (def (apply-chat-event! state chat-event) - (let* ([id (list-ref chat-event 0)] - [title (list-ref chat-event 1)] - [kind (list-ref chat-event 2)] - [target (list-ref chat-event 3)] - [msg (list-ref chat-event 4)] + (cond + [(eq? (car chat-event) 'receipt) + (apply-receipt-event! state (list-ref chat-event 1) (list-ref chat-event 2))] + [(eq? (car chat-event) 'typing) + (apply-typing-event! state (list-ref chat-event 1) (list-ref chat-event 2) + (list-ref chat-event 3))] + [else + (apply-message-event! state (cdr chat-event))])) + + (def (apply-message-event! state ev) + (let* ([id (list-ref ev 0)] + [title (list-ref ev 1)] + [kind (list-ref ev 2)] + [target (list-ref ev 3)] + [msg (list-ref ev 4)] [conv (ensure-conversation! state id title kind target)]) (append-message-to-conversation! conv msg) + ;; A real message from them means they've stopped typing. + (when (eq? (chat-message-direction msg) 'in) + (conversation-typing-set! conv #f)) (unless (selected-conversation? state id) - (conversation-unread-set! conv (+ (conversation-unread conv) 1))))) + (conversation-unread-set! conv (+ (conversation-unread conv) 1))) + (tui-state-status-set! state "New Signal message received."))) + + ;; Match the receipt's timestamps against our outbound messages in every + ;; conversation and upgrade their state. Never downgrade: sent < delivered < + ;; read, so an out-of-order delivery receipt can't undo a read receipt. + (def (apply-receipt-event! state status timestamps) + (let ([updated 0]) + (for-each + (lambda (conv) + (for-each + (lambda (msg) + (when (and (eq? (chat-message-direction msg) 'out) + (timestamp-member? (chat-message-timestamp msg) timestamps) + (status>? status (chat-message-status msg))) + (chat-message-status-set! msg status) + (set! updated (+ updated 1)))) + (conversation-messages conv))) + (tui-state-conversations state)) + (when (> updated 0) + (tui-state-status-set! + state + (string-append "Message " + (if (eq? status 'read) "read." "delivered.")))))) + + ;; Typing is ephemeral: STARTED arms a 15s expiry on an EXISTING thread, + ;; STOPPED clears it. We never resurrect a thread the user has closed. + (def (apply-typing-event! state id sender started?) + (let ([conv (find-conversation (tui-state-conversations state) id)]) + (when conv + (conversation-typing-set! + conv + (and started? (cons sender (+ (real-time) 15000)))) + (tui-state-status-set! + state + (string-append sender + (if started? " is typing\x2026;" " stopped typing.")))))) + + (def (status-rank status) + (cond + [(eq? status 'read) 3] + [(eq? status 'delivered) 2] + [(eq? status 'sent) 1] + [else 0])) + + (def (status>? a b) + (> (status-rank a) (status-rank b))) + + (def (timestamp-member? ts timestamps) + (and (number? ts) + (let loop ([xs timestamps]) + (and (pair? xs) + (or (and (number? (car xs)) (= (car xs) ts)) + (loop (cdr xs))))))) (def (seed-known-conversations! state actor) (tui-state-status-set! state "Loading contacts and groups...") @@ -279,7 +344,8 @@ kind target '() - 0)] + 0 + #f)] [next (append (tui-state-conversations state) (list conv))]) (tui-state-conversations-set! state next) (let ([selected (selected-conversation state)]) @@ -418,11 +484,21 @@ [sender (chat-message-sender msg)] [text (chat-message-text msg)]) (cond - [(eq? dir 'out) (string-append "You: " text)] + [(eq? dir 'out) + (string-append "You: " text (receipt-suffix (chat-message-status msg)))] [(eq? dir 'system) text] [(non-empty-string? sender) (string-append sender ": " text)] [else text]))) + ;; Mirror Signal's check marks on our sent messages: + ;; one check = sent, two = delivered, two + "read" = read. + (def (receipt-suffix status) + (cond + [(eq? status 'read) " \x2713;\x2713; read"] + [(eq? status 'delivered) " \x2713;\x2713;"] + [(eq? status 'sent) " \x2713;"] + [else ""])) + (def (chat-message-fg msg) (let ([dir (chat-message-direction msg)]) (cond @@ -587,7 +663,8 @@ 'direct recipient '() - 0)) + 0 + #f)) matches))) (def (filter-conversations-for-picker conversations query) @@ -673,7 +750,7 @@ [ts (send-result-timestamp result)]) (append-message-to-conversation! conv - (make-chat-message 'out "You" text ts 'data)) + (make-chat-message 'out "You" text ts 'data 'sent)) (capture-outbound! (tui-state-logdb state) (tui-state-account state) (conversation-id conv) text ts)) @@ -1109,6 +1186,12 @@ [(>= n width) (substring s 0 width)] [else (string-append s (make-string (- width n) #\space))]))) + ;; The sender currently typing in this thread, or #f once the 15s window + ;; lapses. Checked on every redraw (~10Hz) so the line clears on its own. + (def (active-typing-sender conv) + (let ([t (conversation-typing conv)]) + (and (pair? t) (> (cdr t) (real-time)) (car t)))) + (def (draw-thread! state x y width height) (let ([conv (selected-conversation state)]) (if conv @@ -1116,13 +1199,19 @@ (draw-text! x y width (fg-strong) (bg) (conversation-title conv)) (draw-text! x (+ y 1) width (fg-dim) (bg) (conversation-subtitle conv)) - (let* ([rows (max 0 (- height 3))] + (let* ([typing (active-typing-sender conv)] + [reserved (if typing 1 0)] + [rows (max 0 (- height 3 reserved))] [messages (last-n-items (conversation-messages conv) rows)]) (let loop ([ms messages] [row (+ y 3)]) - (when (and (pair? ms) (< row (+ y height))) - (draw-text! x row width (chat-message-fg (car ms)) (bg) - (chat-message->line (car ms))) - (loop (cdr ms) (+ row 1)))))) + (if (and (pair? ms) (< row (+ y height))) + (begin + (draw-text! x row width (chat-message-fg (car ms)) (bg) + (chat-message->line (car ms))) + (loop (cdr ms) (+ row 1))) + (when (and typing (< row (+ y height))) + (draw-text! x row width (fg-dim) (bg) + (string-append typing " is typing\x2026;"))))))) (begin (draw-text! x y width (fg-strong) (bg) "jerboa-signal") (draw-text! x (+ y 1) width (fg-dim) (bg) @@ -1262,11 +1351,12 @@ [(hashtable? sync) (sync-message->chat-event account envelope sync)] [(hashtable? receipt) - (simple-envelope-event envelope "receipt" 'receipt)] + (receipt->chat-event receipt)] [(hashtable? typing) - (simple-envelope-event envelope "typing" 'typing)] + (typing->chat-event envelope typing)] [else - (simple-envelope-event envelope "received Signal event" 'event)]))) + (cons 'message + (simple-envelope-event envelope "received Signal event" 'event))]))) (def (data-message->chat-event account envelope data) (let* ([group-target (message-group-id data)] @@ -1281,8 +1371,8 @@ [text (message-text data)] [timestamp (or (hashtable-ref data "timestamp" #f) (hashtable-ref envelope "timestamp" #f))] - [msg (make-chat-message 'in source-title text timestamp 'data)]) - (list id title kind target msg))) + [msg (make-chat-message 'in source-title text timestamp 'data #f)]) + (list 'message id title kind target msg))) (def (sync-message->chat-event account envelope sync) (let ([sent (hashtable-ref sync "sentMessage" #f)]) @@ -1302,8 +1392,8 @@ [text (message-text sent)] [timestamp (or (hashtable-ref sent "timestamp" #f) (hashtable-ref envelope "timestamp" #f))] - [msg (make-chat-message 'out "You" text timestamp 'data)]) - (list id title kind target msg))))) + [msg (make-chat-message 'out "You" text timestamp 'data #f)]) + (list 'message id title kind target msg))))) (def (simple-envelope-event envelope text kind) (let* ([source-title (envelope-source-title envelope)] @@ -1311,9 +1401,40 @@ [id (conversation-id-for 'direct source-target source-title)] [msg (make-chat-message 'in source-title text (hashtable-ref envelope "timestamp" #f) - kind)]) + kind #f)]) (list id source-title 'direct source-target msg))) + ;; A receipt names no thread; it carries the timestamp(s) of OUR sent + ;; messages plus delivery/read flags. apply-receipt-event! matches by ts. + (def (receipt->chat-event receipt) + (list 'receipt (receipt-status receipt) (receipt-timestamps receipt))) + + (def (receipt-status receipt) + (if (or (hashtable-ref receipt "isRead" #f) + (hashtable-ref receipt "isViewed" #f)) + 'read + 'delivered)) + + (def (receipt-timestamps receipt) + (let ([ts (hashtable-ref receipt "timestamps" #f)]) + (if (list? ts) + ts + (let ([w (hashtable-ref receipt "when" #f)]) + (if (number? w) (list w) '()))))) + + ;; STARTED/STOPPED for a direct or group thread; default to started when the + ;; action field is absent so a stray indicator still shows then auto-expires. + (def (typing->chat-event envelope typing) + (let* ([group-target (message-group-id typing)] + [source-title (envelope-source-title envelope)] + [source-target (envelope-source-target envelope)] + [kind (if group-target 'group 'direct)] + [target (if group-target group-target source-target)] + [id (conversation-id-for kind target source-title)] + [action (hashtable-ref typing "action" #f)]) + (list 'typing id source-title + (or (not (string? action)) (string=? action "STARTED"))))) + (def (envelope-source-title envelope) (or (hashtable-ref envelope "sourceName" #f) (hashtable-ref envelope "sourceNumber" #f)