Auto-export incoming attachments to ~/Downloads/jerboa-signal
ober
1ea5bc776132668548b31d82652d6fde4cdfa3e4
new file mode 100644 --- /dev/null +++ b/signal/attach-save.ss @@ -0,0 +1,285 @@ +#!chezscheme +;;; signal/attach-save -- auto-export incoming attachments to a friendly tree. +;;; +;;; signal-cli already downloads every received attachment into its data dir +;;; (<XDG_DATA_HOME or ~/.local/share>/signal-cli/attachments/<id>[.ext]). This +;;; module copies those files, as each message arrives, into +;;; +;;; ~/Downloads/jerboa-signal/<conversation>/<original-name> +;;; +;;; (base overridable with JERBOA_SIGNAL_DOWNLOAD_DIR). It is best-effort: every +;;; entry point swallows errors so saving can never break the receive loop. +;;; Only inbound dataMessage attachments are exported -- not our own sync sends. + +(library (signal attach-save) + (export save-notification-attachments! save-envelope-attachments! download-base) + + (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?)) + + ;; --- entry points ------------------------------------------------------- + + ;; Save attachments from a raw signal-cli JSON-RPC notification. Returns the + ;; list of destination paths written (empty when there's nothing to save). + (def (save-notification-attachments! notif) + (guard (e [#t '()]) + (let ([env (notif-envelope notif)]) + (if (hashtable? env) (save-envelope-attachments! env) '())))) + + (def (save-envelope-attachments! envelope) + (guard (e [#t '()]) + (let ([data (htref envelope "dataMessage")]) + (if (hashtable? data) + (let ([atts (->list (htref data "attachments"))]) + (if (pair? atts) + (let ([folder (conversation-folder envelope data)]) + (let loop ([xs atts] [acc '()]) + (if (null? xs) + (reverse acc) + (let ([dst (save-one folder (car xs))]) + (loop (cdr xs) (if dst (cons dst acc) acc)))))) + '())) + '())))) + + (def (save-one folder attach) + (guard (e [#t #f]) + (and (hashtable? attach) + (let* ([id (->id-string (htref attach "id"))] + [src (find-source-file (attachments-source-dir) id)]) + (and src + (let* ([destdir (string-append (download-base) "/" folder)] + [name (dest-filename attach id src)] + [dst (unique-dest destdir name)]) + (mkdir-p destdir) + (copy-file! src dst) + dst)))))) + + ;; --- locations ---------------------------------------------------------- + + (def (home) (or (getenv "HOME") ".")) + + (def (download-base) + (let ([env (getenv "JERBOA_SIGNAL_DOWNLOAD_DIR")]) + (if (nonempty env) + env + (string-append (home) "/Downloads/jerboa-signal")))) + + (def (attachments-source-dir) + (string-append (signal-cli-data-dir) "/attachments")) + + (def (signal-cli-data-dir) + (let ([ov (getenv "JERBOA_SIGNAL_CLI_DATA_DIR")] + [xdg (getenv "XDG_DATA_HOME")]) + (cond + [(nonempty ov) ov] + [(nonempty xdg) (string-append xdg "/signal-cli")] + [else (string-append (home) "/.local/share/signal-cli")]))) + + ;; --- conversation folder ------------------------------------------------ + + (def (conversation-folder envelope msg) + (let ([gid (data-group-id msg)]) + (if gid + (string-append "group_" (sanitize-dir (short-id gid))) + (sanitize-dir (first-string (htref envelope "sourceName") + (htref envelope "sourceNumber") + (htref envelope "source")))))) + + (def (data-group-id msg) + (or (nonempty (htref msg "groupId")) + (let ([gi (htref msg "groupInfo")]) + (and (hashtable? gi) + (or (nonempty (htref gi "groupId")) + (nonempty (htref gi "groupIdBase64")) + (nonempty (htref gi "id"))))) + (let ([g2 (htref msg "groupV2")]) + (and (hashtable? g2) + (or (nonempty (htref g2 "id")) + (nonempty (htref g2 "masterKey"))))))) + + (def (short-id id) + (if (> (string-length id) 16) (substring id 0 16) id)) + + ;; --- locating the already-downloaded source file ------------------------ + + ;; signal-cli stores the file as "<id>" or "<id>.<ext>". Match either. + (def (find-source-file dir id) + (and (nonempty id) + (file-exists? dir) + (let ([entries (guard (e [#t '()]) (directory-list dir))]) + (let loop ([es entries]) + (cond + [(null? es) #f] + [(entry-matches? (car es) id) + (string-append dir "/" (car es))] + [else (loop (cdr es))]))))) + + (def (entry-matches? entry id) + (or (string=? entry id) + (let ([nid (string-length id)]) + (and (> (string-length entry) nid) + (string=? (substring entry 0 nid) id) + (char=? (string-ref entry nid) #\.))))) + + ;; --- naming the destination --------------------------------------------- + + ;; Prefer the sender's original filename; otherwise fall back to the id plus + ;; whatever extension signal-cli put on the stored file. + (def (dest-filename attach id src) + (let ([orig (htref attach "filename")]) + (if (nonempty orig) + (sanitize-filename orig) + (string-append (sanitize-filename (or id "attachment")) + (file-ext (path-basename src)))))) + + ;; Append " (n)" before the extension until the name is free -- never + ;; overwrite an existing file. + (def (unique-dest dir filename) + (let ([full (string-append dir "/" filename)]) + (if (not (file-exists? full)) + full + (let ([stem (file-stem filename)] + [ext (file-ext filename)]) + (let loop ([n 1]) + (let ([cand (string-append dir "/" stem " (" (number->string n) ")" ext)]) + (if (file-exists? cand) (loop (+ n 1)) cand))))))) + + ;; --- copy --------------------------------------------------------------- + + (def (copy-file! src dst) + (let ([in (open-file-input-port src)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (let ([out (open-file-output-port dst (file-options no-fail))]) + (dynamic-wind + (lambda () (void)) + (lambda () + (let loop () + (let ([chunk (get-bytevector-n in 65536)]) + (unless (eof-object? chunk) + (put-bytevector out chunk) + (loop))))) + (lambda () (close-port out))))) + (lambda () (close-port in))))) + + ;; mkdir each ancestor in turn; the base (~/Downloads) usually exists but the + ;; per-conversation dir won't, and a custom base might be missing entirely. + (def (mkdir-p dir) + (unless (or (string=? dir "") (string=? dir "/") (file-exists? dir)) + (let ([parent (parent-dir dir)]) + (unless (string=? parent dir) (mkdir-p parent))) + (guard (e [#t (void)]) (mkdir dir)))) + + (def (parent-dir path) + (let loop ([i (- (string-length path) 1)]) + (cond + [(< i 0) ""] + [(char=? (string-ref path i) #\/) + (if (= i 0) "/" (substring path 0 i))] + [else (loop (- i 1))]))) + + ;; --- string / path helpers ---------------------------------------------- + + (def (htref ht k) (and (hashtable? ht) (hashtable-ref ht k #f))) + + (def (nonempty v) (and (string? v) (not (string=? v "")) v)) + + (def (->id-string v) + (cond [(string? v) v] [(number? v) (number->string v)] [else #f])) + + (def (->list x) + (cond [(list? x) x] [(vector? x) (vector->list x)] [else '()])) + + (def (first-string . vs) + (let loop ([xs vs]) + (cond [(null? xs) "unknown"] + [(nonempty (car xs)) (car xs)] + [else (loop (cdr xs))]))) + + (def (path-basename path) + (let loop ([i (- (string-length path) 1)]) + (cond + [(< i 0) path] + [(char=? (string-ref path i) #\/) + (substring path (+ i 1) (string-length path))] + [else (loop (- i 1))]))) + + ;; Extension including the dot (".jpg"), or "" when there is none. + (def (file-ext name) + (let loop ([i (- (string-length name) 1)]) + (cond + [(< i 0) ""] + [(char=? (string-ref name i) #\/) ""] + [(char=? (string-ref name i) #\.) (substring name i (string-length name))] + [else (loop (- i 1))]))) + + (def (file-stem name) + (let ([e (file-ext name)]) + (if (string=? e "") + name + (substring name 0 (- (string-length name) (string-length e)))))) + + ;; Folder names: keep readable chars, collapse the rest, drop leading/trailing + ;; dots and spaces, and never yield "", "." or "..". + (def (sanitize-dir s) + (let* ([str (if (nonempty s) s "unknown")] + [cleaned (list->string (map dir-safe-char (string->list str)))] + [t (trim-dots-spaces cleaned)]) + (if (string=? t "") "unknown" t))) + + (def (dir-safe-char c) + (if (or (char-alphabetic? c) (char-numeric? c) + (char=? c #\space) (char=? c #\.) (char=? c #\_) + (char=? c #\-) (char=? c #\+)) + c #\_)) + + ;; Filenames: same idea but keep parens, and strip any directory part first so + ;; a hostile "../../x" can't escape the conversation folder. + (def (sanitize-filename name) + (let* ([base (path-basename (if (nonempty name) name "attachment"))] + [cleaned (list->string (map file-safe-char (string->list base)))]) + (cond + [(string=? cleaned "") "attachment"] + [(string=? cleaned ".") "attachment"] + [(string=? cleaned "..") "attachment"] + [else cleaned]))) + + (def (file-safe-char c) + (if (or (char-alphabetic? c) (char-numeric? c) + (char=? c #\space) (char=? c #\.) (char=? c #\_) + (char=? c #\-) (char=? c #\+) (char=? c #\() (char=? c #\))) + c #\_)) + + (def (trim-dots-spaces s) + (let* ([n (string-length s)] + [start (let loop ([i 0]) + (if (and (< i n) (trim-char? (string-ref s i))) + (loop (+ i 1)) + i))] + [end (let loop ([i n]) + (if (and (> i start) (trim-char? (string-ref s (- i 1)))) + (loop (- i 1)) + i))]) + (substring s start end))) + + (def (trim-char? c) (or (char=? c #\space) (char=? c #\.))) + + ;; --- notification unwrap (mirrors capture/tui) -------------------------- + + (def (notif-envelope notif) + (and (hashtable? notif) + (let ([params (htref notif "params")]) + (and (hashtable? params) + (let ([payload (or (htref params "result") params)]) + (and (hashtable? payload) (htref payload "envelope"))))))) + + ) ;; end library --- a/signal/cmd-listen.ss +++ b/signal/cmd-listen.ss @@ -20,7 +20,8 @@ make-date make-time) (except (jerboa prelude) meta atom?) (std text json) - (signal rpc)) + (signal rpc) + (signal attach-save)) (def (cmd-listen account) (let ([sc (spawn-signal-cli account)]) @@ -34,6 +35,7 @@ (display "signal-cli stream ended\n" (current-error-port))] [else (emit-envelope n) + (save-notification-attachments! n) (loop)])))) (lambda () (close-signal-cli sc))))) --- a/signal/tui/main.ss +++ b/signal/tui/main.ss @@ -18,6 +18,7 @@ (signal store) (signal logdb) (signal capture) + (signal attach-save) (signal tui ffi)) (defstruct chat-message (direction sender text timestamp kind status)) @@ -118,7 +119,16 @@ (let ([line (notification->line notif)]) (when line (append-system-message! state line) - (tui-state-status-set! state "New Signal event received.")))))] + (tui-state-status-set! state "New Signal event received.")))) + (let ([saved (save-notification-attachments! notif)]) + (when (pair? saved) + (tui-state-status-set! + state + (string-append "Saved " + (number->string (length saved)) + (if (= (length saved) 1) " file to " + " files to ") + (download-base))))))] [(and (pair? ev) (eq? (car ev) 'closed)) (tui-state-status-set! state