diff options
Diffstat (limited to 'lib/net')
-rw-r--r-- | lib/net/jao-eww-session.el | 10 | ||||
-rw-r--r-- | lib/net/jao-frm.el | 222 | ||||
-rw-r--r-- | lib/net/jao-notmuch-gnus.el | 213 | ||||
-rw-r--r-- | lib/net/jao-notmuch.el | 315 | ||||
-rw-r--r-- | lib/net/jao-proton-utils.el | 141 | ||||
-rw-r--r-- | lib/net/signel.org | 546 |
6 files changed, 284 insertions, 1163 deletions
diff --git a/lib/net/jao-eww-session.el b/lib/net/jao-eww-session.el index 9a34656..4ac5447 100644 --- a/lib/net/jao-eww-session.el +++ b/lib/net/jao-eww-session.el @@ -86,7 +86,7 @@ the session is already displayed in a eww tab, jao-eww-session can: (defvar jao-eww-current-session '(jao-eww-session 0 nil)) -(defun jao-eww-session--list-buffers (&optional skip) +(defun jao-eww-session-eww-buffers (&optional skip) (seq-filter (lambda (b) (when (not (eq b skip)) (with-current-buffer b (derived-mode-p 'eww-mode)))) @@ -94,7 +94,7 @@ the session is already displayed in a eww tab, jao-eww-session can: (defun jao-eww-session-invisible-buffers () (seq-filter (lambda (b) (null (get-buffer-window b))) - (jao-eww-session--list-buffers (current-buffer)))) + (jao-eww-session-eww-buffers (current-buffer)))) (defun jao-eww--current-url () (when-let (url (eww-current-url)) (url-encode-url url))) @@ -104,7 +104,7 @@ the session is already displayed in a eww tab, jao-eww-session can: (cb (current-buffer)) (pos 0) (count 0)) - (dolist (b (jao-eww-session--list-buffers (when skip-current cb)) + (dolist (b (jao-eww-session-eww-buffers (when skip-current cb)) (list pos (reverse urls))) (set-buffer b) (when-let (url (jao-eww--current-url)) @@ -141,7 +141,7 @@ the session is already displayed in a eww tab, jao-eww-session can: (or (and (eq jao-eww-session-duplicate-tabs 'never)) (not (y-or-n-p (format "'%s' (%s) is already open. Duplicate? " (jao-eww-buffer-title) url)))))))) - (jao-eww-session--list-buffers))) + (jao-eww-session-eww-buffers))) (defun jao-eww-session-load-aux () (let ((new-session (jao-eww-session-from-file @@ -226,7 +226,7 @@ the session is already displayed in a eww tab, jao-eww-session can: (dolist (url urls) (eww url 4)) (seq-each #'kill-buffer buffers) (unless (zerop offset) - (switch-to-buffer (nth offset (jao-eww-session--list-buffers))))))) + (switch-to-buffer (nth offset (jao-eww-session-eww-buffers))))))) (provide 'jao-eww-session) ;;; jao-eww-session.el ends here diff --git a/lib/net/jao-frm.el b/lib/net/jao-frm.el deleted file mode 100644 index 2658687..0000000 --- a/lib/net/jao-frm.el +++ /dev/null @@ -1,222 +0,0 @@ -;;; jao-frm.el --- use frm to show mailbox - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2019, 2020 - -;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> -;; Keywords: mail - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Little hack to see the contents of your mailbox using GNU mailutils' -;; `frm' program. -;; -;; Just put (require 'jao-frm) in your .emacs, and M-x jao-frm will pop up a -;; new window with your mailbox contents (from and subject) as -;; printed by frm. In this buffer, use `n' and `p' to move, `q' to close -;; the window. `g' will call Gnus. -;; - -;;; Code: - -;;;; Customisation: - -(defgroup jao-frm nil - "Frm-base mailbox checker" - :group 'mail - :prefix "jao-frm-") - -(defcustom jao-frm-exec-path "frm" - "frm executable path" - :group 'jao-frm - :type 'file) - -(defcustom jao-frm-mail-command 'gnus - "Emacs function to invoke when `g' is pressed on an frm buffer." - :group 'jao-frm - :type 'symbol) - -(defcustom jao-frm-mailboxes nil - "List of mailboxes to check, or directory containing them." - :group 'jao-frm - :type '(choice directory (repeat file))) - -(defface jao-frm-mailno-face '((t (:foreground "dark slate grey"))) - "Face for the mail number." - :group 'jao-frm) - -(defface jao-frm-from-face '((t (:foreground "slate grey"))) - "Face for From: header." - :group 'jao-frm) - -(defface jao-frm-subject-face '((t (:foreground "slate blue"))) - "Face for Subject: header." - :group 'jao-frm) - -(defface jao-frm-mailbox-face '((t (:bold t :weight bold))) - "Face for mailbox name." - :group 'jao-frm) - -;;;; Mode: - -(defvar jao-frm-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map [?q] 'jao-frm-delete-window) - (define-key map [?n] 'next-line) - (define-key map [?p] 'previous-line) - (define-key map [?r] 'jao-frm) - (define-key map [?g] (lambda () - (interactive) - (funcall jao-frm-mail-command))) - (define-key map [(control k)] 'jao-frm-delete-message) - map)) - -(setq jao-frm-font-lock-keywords - '(("^[^ :]+:" . 'jao-frm-mailbox-face) - ("^\\([ 0-9]+\\):\t+\\([^\t]+\\)\t+\\([^\n]+$\\)" - (1 'jao-frm-mailno-face) - (2 'jao-frm-from-face) - (3 'jao-frm-subject-face)))) - -(defvar jao-frm-mode-syntax-table - (let ((st (make-syntax-table))) - st)) - -(defun jao-frm-mode () - "Major mode for displaying frm output." - (interactive) - (kill-all-local-variables) - (buffer-disable-undo) - (use-local-map jao-frm-mode-map) - (set (make-local-variable 'font-lock-defaults) - '(jao-frm-font-lock-keywords)) - (set (make-local-variable 'truncate-lines) t) - (set (make-local-variable 'kill-whole-line) t) - (set (make-local-variable 'next-line-add-newlines) nil) - (setq major-mode 'jao-frm-mode) - (setq mode-name "frm") - (read-only-mode 1) - (goto-char 1)) - -;;;; Mode commands: -(defvar jao-frm-last-config nil) - -(defun jao-frm-delete-window () - "Delete frm window and restore last win config" - (interactive) - (if (and (consp jao-frm-last-config) - (window-configuration-p (car jao-frm-last-config))) - (progn - (set-window-configuration (car jao-frm-last-config)) - (goto-char (cadr jao-frm-last-config)) - (setq jao-frm-last-config nil)) - (bury-buffer))) - -(defun jao-frm-delete-message () - "Delete message at point" - (interactive) - (when (eq (current-buffer) (get-buffer "*frm*")) - (beginning-of-line) - (when (search-forward-regexp "^ +\\([0-9]+\\):" nil t) - (let ((mn (string-to-number (match-string 1)))) - (when (y-or-n-p (format "Delete message number %d? " mn)) - (read-only-mode -1) - (shell-command (format "echo 'd %d'|mail" mn) t) - (jao-frm) - (when (= (point-max) (point-min)) - (jao-frm-delete-window) - (message "Mailbox is empty"))))))) - -;;;; Activate frm: -(defun jao-frm-mbox-mails (mbox) - (let ((no (ignore-errors - (substring - (shell-command-to-string (format "frm -s n %s|wc -l" mbox)) - 0 -1)))) - (if (stringp no) (string-to-number no) 0))) - -(defun jao-frm-mail-number () - (let ((no 0)) - (dolist (b (jao-frm-mboxes) no) (setq no (+ no (jao-frm-mbox-mails b)))))) - -(defun jao-frm-default-count-formatter (m n) - (format "%s: %s" (file-name-sans-extension (file-name-nondirectory m)) n)) - -(defun jao-frm-mail-counts (fmt) - (let ((fmt (or fmt 'jao-frm-default-count-formatter))) - (remove nil - (mapcar (lambda (m) - (let ((n (jao-frm-mbox-mails m))) - (unless (zerop n) (funcall fmt m n)))) - (jao-frm-mboxes))))) - -(defun jao-frm-display-mailbox (mbox) - (when (not (zerop (jao-frm-mbox-mails mbox))) - (insert (or (file-name-nondirectory mbox) mbox) ":\n\n") - (apply 'call-process - `(,jao-frm-exec-path nil ,(current-buffer) nil - "-s" "n" "-n" "-t" ,@(and mbox (list mbox)))) - (newline 2))) - -(defun jao-frm-mboxes () - (cond ((null jao-frm-mailboxes) (list (getenv "MAIL"))) - ((listp jao-frm-mailboxes) jao-frm-mailboxes) - ((stringp jao-frm-mailboxes) - (if (file-directory-p jao-frm-mailboxes) - (directory-files jao-frm-mailboxes t "^[^.]") - (list jao-frm-mailboxes))) - (t (error "Error in mbox specification. Check `jao-frm-mailboxes'")))) - -;;;###autoload -(defun jao-frm () - "Run frm." - (interactive) - (let ((fbuff (get-buffer-create "*frm*")) - (inhibit-read-only t)) - (if (not (eq fbuff (current-buffer))) - (setq jao-frm-last-config - (list (current-window-configuration) (point-marker)))) - (with-current-buffer fbuff - (delete-region (point-min) (point-max)) - (mapc 'jao-frm-display-mailbox (jao-frm-mboxes)) - (unless (eq major-mode 'jao-frm-mode) - (jao-frm-mode)) - (goto-char (point-min)) - (if (= (point-min) (point-max)) - (message "Mailbox is empty.") - (pop-to-buffer fbuff)) - (when (and (boundp 'display-time-mode) display-time-mode) - (display-time-update))))) - -;;;###autoload -(defun jao-frm-show-mail-numbers (&optional fmt) - (interactive) - (let ((counts (jao-frm-mail-counts fmt))) - (message (if counts (mapconcat 'identity counts ", ") "No mail")))) - -;;;###autoload -(defun jao-frm-mail-string () - (let ((counts (jao-frm-mail-counts - (lambda (m n) - (let ((m (substring (file-name-nondirectory m) 0 1))) - (format "%s%s" (capitalize m) n)))))) - (mapconcat 'identity counts " "))) - -(provide 'jao-frm) - -;;; jao-frm.el ends here diff --git a/lib/net/jao-notmuch-gnus.el b/lib/net/jao-notmuch-gnus.el deleted file mode 100644 index e18c5a1..0000000 --- a/lib/net/jao-notmuch-gnus.el +++ /dev/null @@ -1,213 +0,0 @@ -;;; jao-notmuch-gnus.el --- notmuch-gnus interoperability -*- lexical-binding: t; -*- - -;; Copyright (C) 2022 jao - -;; Author: jao <mail@jao.io> -;; Keywords: mail - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Helper functions to work in Gnus with mail indexed by notmuch. - -;;; Code: - -(require 'gnus) -(require 'ol-gnus) -(require 'notmuch-show) - - -;;; Tagging in notmuch from Gnus buffers - -(defun jao-notmuch-gnus--notmuch-id (id) - (when id (if (string-match "<\\(.+\\)>" id) (match-string 1 id) id))) - -(defun jao-notmuch-gnus-message-id (&optional no-show) - "Find the id of currently selected message in Gnus or notmuch." - (when (and (not no-show) (derived-mode-p 'gnus-summary-mode)) - (save-window-excursion (gnus-summary-show-article))) - (cond (gnus-original-article-buffer - (with-current-buffer gnus-original-article-buffer - (jao-notmuch-gnus--notmuch-id (message-field-value "message-id")))) - ((derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode) - (notmuch-show-get-message-id)))) - -(defun jao-notmuch-gnus-message-tags (id) - "Ask notmuch for the tags of a message with the given ID." - (let ((cmd (format "notmuch search --output=tags 'id:%s'" id))) - (split-string (shell-command-to-string cmd)))) - -(defun jao-notmuch-gnus-tag-message (&optional id tags no-log) - "Interactively add or remove tags to the current message." - (interactive) - (let* ((id (or id (jao-notmuch-gnus-message-id))) - (current (unless tags (jao-notmuch-gnus-message-tags id))) - (prompt (format "Change tags %s" (string-join current "/"))) - (tags (or tags (notmuch-read-tag-changes current prompt)))) - (notmuch-tag (concat "id:" id) tags) - (unless no-log - (message "%s -> %s" current (jao-notmuch-gnus-message-tags id))))) - -(defun jao-notmuch-gnus-show-tags () - "Display in the echo area the tags of the current message." - (interactive) - (when-let (id (jao-notmuch-gnus-message-id)) - (message "%s" (string-join (jao-notmuch-gnus-message-tags id) " ")))) - -(defun jao-notmuch-gnus-toggle-tags (tags &optional id current) - "Toggle the given TAGS list for the current Gnus message." - (let* ((id (or id (jao-notmuch-gnus-message-id))) - (current (or current (jao-notmuch-gnus-message-tags id))) - (tags (mapcar (lambda (x) - (concat (if (member x current) "-" "+") x)) - tags))) - (notmuch-tag (concat "id:" id) tags) - (message "New tags: %s" (jao-notmuch-gnus-message-tags id)))) - -(defun jao-notmuch-gnus-tag-mark () - "Remove the new tag for an article when it's marked as seen by Gnus." - (when-let (id (jao-notmuch-gnus-message-id t)) - (jao-notmuch-gnus-tag-message id '("-new") t))) - -(add-hook 'gnus-mark-article-hook #'jao-notmuch-gnus-tag-mark) - -(defun jao-notmuch-gnus--group-tags (group) - (when (string-match ".+:\\(.+\\)" group) - (split-string (match-string 1 group) "\\."))) - -(defun jao-notmuch-gnus-tag-on-move (op headers from to _d) - (when-let* ((to-tags (when to (jao-notmuch-gnus--group-tags to))) - (id (jao-notmuch-gnus--notmuch-id (mail-header-id headers)))) - (if (eq op 'delete) - (let ((cur (seq-difference (jao-notmuch-gnus--group-tags from) to-tags))) - (jao-notmuch-gnus-toggle-tags (append cur to-tags) id cur)) - (notmuch-tag (concat "id:" id) - (mapcar (lambda (x) (concat "+" x)) to-tags))))) - -(defun jao-notmuch-gnus-auto-tag () - (add-hook 'gnus-summary-article-move-hook #'jao-notmuch-gnus-tag-on-move) - (add-hook 'gnus-summary-article-expire-hook #'jao-notmuch-gnus-tag-on-move)) - - -;;;; Displaying search results in Gnus - -(defvar jao-notmuch-gnus-server "nnml" - "Name of the target Gnus server, e.g. nnml+mail.") - -(defvar jao-notmuch-gnus-mail-directory (expand-file-name "~/.emacs.d/gnus/Mail") - "Directory where Gnus stores its mail.") - -(defvar jao-notmuch-gnus-leafnode-directory (expand-file-name "~/var/news") - "Directory where leafnode stores its messages as seen by notmuch.") - -(defun jao-notmuch-gnus-file-to-group (file &optional maildir newsdir) - "Compute the Gnus group name from the given file name. -Example: - - IN: /home/jao/var/mail/jao/foo/cur/1259184569.M4818P3384.localhost,W=6921:2,S - OUT: nnml:jao.foo - - IN: /home/jao/.emacs.d/gnus/Mail/jao.trove/32, /home/jao/.emacs.d/gnus/Mail/ - OUT: nnml:jao.trove - - IN: /home/jao/var/mail/gmane/foo/bar/100 - OUT: nntp:gmane.foo.bar - - IN: /home/jao/var/mail/bigml/cur/1259176906.M17483P24679.localhost,W=2488:2,S - OUT:nnimap:bigml/inbox" - (let* ((maildir (or maildir jao-notmuch-gnus-mail-directory)) - (newsdir (or newsdir jao-notmuch-gnus-leafnode-directory)) - (g (directory-file-name (file-name-directory file))) - (g (replace-regexp-in-string (file-name-as-directory maildir) "" g)) - (g (replace-regexp-in-string (file-name-as-directory newsdir) "" g)) - (nntp (string-match-p "^\\(gmane\\|gwene\\)/" g)) - (g (cond (nntp (concat "nntp:" g)) - ((file-name-directory g) - (replace-regexp-in-string "^\\([^/]+\\)/" - (concat jao-notmuch-gnus-server - ":\\1/") - (file-name-directory g) t)) - (t (concat jao-notmuch-gnus-server ":" g)))) - (g (replace-regexp-in-string "/" "." g)) - (g (replace-regexp-in-string "[/.]$" "" g))) - (cond ((string-match ":$" g) (concat g "inbox")) - (nntp g) - (t (replace-regexp-in-string ":\\." ":" g))))) - -(defun jao-notmuch-gnus-id-to-file (id) - (when id - (let ((cmd (format "notmuch search --output=files %s" id))) - (string-trim (shell-command-to-string cmd))))) - -(defun jao-notmuch-gnus-goto-message (&optional msg-id filename) - "Open a summary buffer containing the current notmuch article." - (interactive) - (let* ((filename (or filename - (jao-notmuch-gnus-id-to-file msg-id) - (notmuch-show-get-filename))) - (group (when filename (jao-notmuch-gnus-file-to-group filename))) - (msg-id (or msg-id (notmuch-show-get-message-id))) - (msg-id (when msg-id (replace-regexp-in-string "^id:" "" msg-id)))) - (if (and group msg-id) - (org-gnus-follow-link group msg-id) - (message "Couldn't get relevant infos for switching to Gnus.")))) - - -;;;; Org links -(defun jao-notmuch-gnus--fname (id) - (let ((cmd (format "notmuch search --output=files id:%s" id))) - (car (split-string (shell-command-to-string cmd))))) - -(defun jao-notmuch-gnus-org-follow (id) - (when-let* ((fname (jao-notmuch-gnus--fname id)) - (group (jao-notmuch-gnus-file-to-group fname))) - (org-gnus-follow-link group id))) - -(defun jao-notmuch-gnus-org-store () - (when-let (d (or (when (derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode) - (cons (notmuch-show-get-message-id) - (notmuch-show-get-subject))) - (when (derived-mode-p 'gnus-summary-mode 'gnus-article-mode) - (cons (jao-notmuch-gnus-message-id) - (gnus-summary-article-subject))))) - (org-link-store-props :type "mail" - :link (concat "mail:" (car d)) - :description (concat "Mail: " (cdr d))))) - -(org-link-set-parameters "mail" - :follow #'jao-notmuch-gnus-org-follow - :store #'jao-notmuch-gnus-org-store) - -(org-link-set-parameters "gnus" :store #'ignore) -(org-link-set-parameters "notmuch" :store #'ignore) - - -;;;; consult-notmuch - -(with-eval-after-load "consult-notmuch" - (defun jao-notmuch-gnus--open-candidate (candidate) - "Open a notmuch-search completion candidate email in Gnus." - (message "candidate: %S" candidate) - (jao-notmuch-gnus-goto-message (consult-notmuch--thread-id candidate))) - - (defun jao-gnus-consult-notmuch () - "Run a consult-notmuch query that opens candidates in Gnus." - (interactive) - (jao-notmuch-gnus--open-candidate (consult-notmuch--search))) - - (consult-customize jao-gnus-consult-notmuch :preview-key 'any)) - -(provide 'jao-notmuch-gnus) -;;; jao-notmuch-gnus.el ends here diff --git a/lib/net/jao-notmuch.el b/lib/net/jao-notmuch.el index bd48e8f..aef9757 100644 --- a/lib/net/jao-notmuch.el +++ b/lib/net/jao-notmuch.el @@ -1,6 +1,6 @@ -;;; jao-notmuch.el --- Extensions for notmuch -*- lexical-binding: t; -*- +;;; jao-notmuch.el --- Extensions for notmuch -*- lexical-binding: t; -*- -;; Copyright (C) 2021, 2022 jao +;; Copyright (C) 2021, 2022, 2023, 2024 jao ;; Author: jao <mail@jao.io> ;; Keywords: mail @@ -18,11 +18,9 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <https://www.gnu.org/licenses/>. -;;; Commentary: +;; Extensions to vanilla notmuch, mostly for tree view -;; Extensions to vanilla notmuch, mostly for tree view - -;;; Code: +;;; require: (require 'outline) (require 'mm-decode) @@ -32,8 +30,8 @@ (require 'notmuch-tree) (require 'notmuch-show) - -;;;; Targetting the displayed message from the tree view + +;;; targetting the displayed message from the tree view (defvar-local jao-notmuch--tree-buffer nil) (declare eww--url-at-point "eww") @@ -54,12 +52,6 @@ (notmuch-tree-close-message-window) (notmuch-tree-show-message nil))) -(defun jao-notmuch-click-message-buffer () - (interactive) - (let ((b (current-buffer))) - (unless (eq 'url (jao-notmuch-goto-message-buffer t t)) - (pop-to-buffer b)))) - (defun jao-notmuch-tree--find-tree-buffer () (or jao-notmuch--tree-buffer (let ((mb (current-buffer))) @@ -87,7 +79,7 @@ (if (not (jao-notmuch-tree--looking-at-message)) (jao-notmuch-tree-show-or-scroll t) (if (notmuch-tree-scroll-message-window) - (jao-notmuch-tree-next nil) + (notmuch-tree-outline-next) (when (not (window-live-p notmuch-tree-message-window)) (notmuch-tree-show-message nil))))) @@ -130,8 +122,8 @@ (completing-read "Browse URL: " urls)) (message "No URLs in this message"))) - -;;;; Navigating URLs + +;;; navigating URLs (require 'ffap) @@ -157,8 +149,8 @@ (thing-at-point-url-at-point))) (browse-url url))) - -;;;; Toggling mime parts and images + +;;; toggling mime parts and images (defun jao-notmuch--toggle-mime () (save-excursion @@ -207,15 +199,20 @@ (defun jao-notmuch-toggle-images () (interactive) - (cond ((eq mm-text-html-renderer 'w3m) - (when (fboundp 'jao-notmuch--w3m-toggle-images) - (jao-notmuch--w3m-toggle-images))) + (cond ((memq mm-text-html-renderer '(w3m jao-w3m-html-renderer)) + (when (fboundp 'jao-notmuch--w3m-toggle-images) + (jao-notmuch--w3m-toggle-images))) (window-system (jao-notmuch--shr-toggle-images)) - (t (with-current-buffer notmuch-tree-message-buffer - (jao-notmuch--view-html))))) + (notmuch-tree-message-buffer + (if nil ;;(fboundp 'jao-open-in-x-frame) + (let ((w (get-buffer-window notmuch-tree-message-buffer))) + (jao-open-in-x-frame (window-width w) (window-height w)) + (jao-notmuch--shr-toggle-images) + (delete-window)) + (with-current-buffer notmuch-tree-message-buffer + (jao-notmuch--view-html)))))) - -;;;; Keeping track of unread messages in current tree view +;;; header line with thread message counts (defun jao-notmuch--looking-at-new-p (&optional p) (when-let (ts (if p (plist-get p :tags) (notmuch-show-get-tags))) @@ -224,23 +221,24 @@ (defsubst jao-notmuch-tree--first-p (&optional msg) (plist-get (or msg (notmuch-tree-get-message-properties)) :first)) -(defun jao-notmuch--message-counts (&optional thread) - (let ((cnt) (total 0) (match 0) (msg)) - (save-excursion - (if thread - (while (and (not (jao-notmuch-tree--first-p)) - (zerop (forward-line -1)))) - (goto-char (point-min))) - (while (and (setq msg (notmuch-tree-get-message-properties)) - (or (not cnt) - (not thread) - (not (jao-notmuch-tree--first-p msg)))) - (unless cnt (setq cnt 0)) - (setq total (1+ total)) - (when (plist-get msg :match) (setq match (1+ match))) - (when (jao-notmuch--looking-at-new-p msg) (setq cnt (1+ cnt))) - (forward-line 1))) - (when cnt (list total match cnt)))) +(defun jao-notmuch--message-counts (tree-buffer &optional thread) + (with-current-buffer tree-buffer + (let ((cnt) (total 0) (match 0) (msg)) + (save-excursion + (if thread + (while (and (not (jao-notmuch-tree--first-p)) + (zerop (forward-line -1)))) + (goto-char (point-min))) + (while (and (setq msg (notmuch-tree-get-message-properties)) + (or (not cnt) + (not thread) + (not (jao-notmuch-tree--first-p msg)))) + (unless cnt (setq cnt 0)) + (setq total (1+ total)) + (when (plist-get msg :match) (setq match (1+ match))) + (when (jao-notmuch--looking-at-new-p msg) (setq cnt (1+ cnt))) + (forward-line 1))) + (when cnt (list total match cnt))))) (defvar jao-notmuch-header-line-format "%Q [%N / %M / %T] %n / %m / %t") @@ -249,186 +247,149 @@ `((?Q . ,query) (?T . ,total) (?N . ,new) (?M . ,match) (?t . ,ttotal) (?n . ,tnew) (?m . ,tmatch)))) -(defun jao-notmuch--update-header-line (mb) - (let* ((n (or (jao-notmuch--message-counts) '(0 0 0))) - (nc (append n (or (jao-notmuch--message-counts t) '(0 0 0)))) - (q (buffer-name))) - (with-current-buffer mb +(defun jao-notmuch--format-header-line (tree-buffer buffer subject) + (let* ((n (jao-notmuch--message-counts tree-buffer)) + (nc (jao-notmuch--message-counts tree-buffer t))) + (with-current-buffer buffer (when (derived-mode-p 'notmuch-show-mode) - (let* ((s (thread-last (notmuch-show-get-subject) - (notmuch-show-strip-re) - (notmuch-sanitize))) + (let* ((nc (append (or n '(0 0 0)) (or nc '(0 0 0)))) + (q (if (string= tree-buffer subject) "" tree-buffer)) (c (apply 'jao-notmuch--format-counts q nc)) - (n (- (window-width) 3 (string-width s) (string-width c))) - (s (if (< n 0) (substring s 0 (- n 4)) s)) - (n (if (< n 0) 5 (1+ n)))) - (setq-local header-line-format - (concat " " s (make-string n ? ) c))))))) - -(defun jao-notmuch-tree--find-update-header-line (&rest _args) - (when-let ((mb (if (derived-mode-p 'notmuch-show-mode) - (current-buffer) - (window-buffer notmuch-tree-message-window)))) - (seq-find (lambda (b) - (with-current-buffer b - (and (derived-mode-p 'notmuch-tree-mode) - (or (null notmuch-tree-message-buffer) - (eq notmuch-tree-message-buffer mb)) - (jao-notmuch--update-header-line mb)))) - (buffer-list)))) - -(add-hook 'notmuch-after-tag-hook #'jao-notmuch-tree--find-update-header-line) -(add-hook 'notmuch-show-hook #'jao-notmuch-tree--find-update-header-line) - - -;;;; Outline mode for tree view - -(defun jao-notmuch-tree--msg-prefix (msg) - (insert (propertize (if (plist-get msg :first) "> " " ") 'display " "))) - -(defun jao-notmuch-tree--mode-setup () - (setq-local outline-regexp "^> \\|^En") - (outline-minor-mode t)) - -(defun jao-notmuch-tree-hide-others (&optional and-show) - (interactive) - (outline-hide-body) - (outline-show-entry) - (when and-show (notmuch-tree-show-message nil))) - -(defun jao-notmuch-tree--next (prev thread no-exit &optional ignore-new) - (let ((line-move-ignore-invisible nil)) - (cond ((and (not ignore-new) (jao-notmuch--looking-at-new-p))) - (thread - (notmuch-tree-next-thread prev) - (unless (or (not (notmuch-tree-get-message-properties)) - (jao-notmuch--looking-at-new-p)) - (notmuch-tree-matching-message prev (not no-exit)))) - (t (notmuch-tree-matching-message prev (not no-exit))))) - (when (notmuch-tree-get-message-id) - (jao-notmuch-tree-hide-others t)) - (when prev (forward-char 2))) - -(defvar jao-notmuch-tree--prefix-map - (let ((m (make-keymap "Thread operations"))) - (define-key m (kbd "TAB") #'outline-cycle) - (define-key m (kbd "t") #'outline-toggle-children) - (define-key m (kbd "s") #'outline-show-entry) - (define-key m (kbd "S") #'outline-show-all) - (define-key m (kbd "h") #'outline-hide-entry) - (define-key m (kbd "H") #'outline-hide-body) - (define-key m (kbd "o") #'jao-notmuch-tree-hide-others) - (define-key m (kbd "n") #'outline-hide-other) - m)) - -(defun jao-notmuch-tree-outline-setup (&optional prefix) - (define-key notmuch-tree-mode-map (kbd (or prefix "T")) - jao-notmuch-tree--prefix-map) - (define-key notmuch-tree-mode-map (kbd "TAB") #'outline-cycle) - (define-key notmuch-tree-mode-map (kbd "M-TAB") #'outline-cycle-buffer) - (add-hook 'notmuch-tree-mode-hook #'jao-notmuch-tree--mode-setup) - (advice-add 'notmuch-tree-insert-msg :before #'jao-notmuch-tree--msg-prefix)) - -(defun jao-notmuch-tree-next (thread &optional no-exit) - "Next message or thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next nil thread no-exit)) + (n (- (window-width) 2 (string-width subject) (string-width c))) + (subject (if (< n 0) (substring subject 0 n) subject)) + (n (if (< n 0) 2 (+ n 2)))) + (concat (when window-system " ") subject (make-string n ? ) c)))))) -(defun jao-notmuch-tree-next-thread (&optional exit) - "Next thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next nil t exit)) +(defun jao-notmuch-message-header-line (subject) + (if-let* ((cb (buffer-name (current-buffer))) + (tb (seq-find (lambda (b) + (with-current-buffer b + (and (derived-mode-p 'notmuch-tree-mode) b))) + (buffer-list)))) + `((:eval (jao-notmuch--format-header-line ,(buffer-name tb) ,cb ,subject))) + (concat " " subject))) -(defun jao-notmuch-tree-previous (thread) - "Previous message or thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next t thread t)) +(defun jao-notmuch--format-lighter () + (when (derived-mode-p 'notmuch-tree-mode) + (let* ((n (jao-notmuch--message-counts (current-buffer))) + (nc (jao-notmuch--message-counts (current-buffer) t)) + (nc (append (or n '(0 0 0)) (or nc '(0 0 0))))) + (apply 'jao-notmuch--format-counts "" nc)))) -(defun jao-notmuch-tree-previous-thread (&optional exit) - "Previous thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next t t exit)) - - -;;;; Updating the tree window after insertion - -(defun jao-notmuch--tree-sentinel (proc &rest _) - (when (eq (process-status proc) 'exit) - (jao-notmuch-tree-hide-others))) +(define-minor-mode jao-notmuch-thread-info-mode "" + :lighter (:eval (format " %s" (jao-notmuch--format-lighter)))) -(defun jao-notmuch-tree-setup (&optional prefix) - "Set up display of trees, with PREFIX key for outline commands." - (jao-notmuch-tree-outline-setup prefix) - (advice-add 'notmuch-tree-process-sentinel :after #'jao-notmuch--tree-sentinel)) - -;;;; Tagging +;;; tagging (defsubst jao-notmuch--has-tag (tag) (member tag (notmuch-tree-get-tags))) -(defun jao-notmuch-tag-jump-and-next (reverse) - (interactive "P") - (notmuch-tag-jump reverse) - (jao-notmuch-tree-next nil t)) - -(defun jao-notmuch-tree--tag (tags reverse whole-thread) +(defun jao-notmuch-tree--tag (tags reverse) (let ((c (notmuch-tag-change-list tags reverse))) - (if whole-thread (notmuch-tree-tag-thread c) (notmuch-tree-tag c)))) - -(defun jao-notmuch-tree--tag-and-next (tags reverse whole-thread) - (jao-notmuch-tree--tag tags reverse whole-thread) - (jao-notmuch-tree-next whole-thread t)) + (notmuch-tree-tag c))) + +(defun jao-notmuch-tree-tag-thread (tags reverse full) + (when full (notmuch-tree-thread-top)) + (let ((c (notmuch-tag-change-list tags reverse)) + (level (or (notmuch-tree-get-prop :level) 0)) + (go t)) + (while go + (notmuch-tree-tag c) + (forward-line) + (setq go (> (or (notmuch-tree-get-prop :level) 0) level))) + (when notmuch-tree-outline-mode + (ignore-errors (outline-show-branches)) + (notmuch-tree-outline-next)))) + +(defun jao-notmuch-tree--tag-and-next (tags reverse) + (jao-notmuch-tree--tag tags reverse) + (notmuch-tree-outline-next t)) (defun jao-notmuch-tree-toggle-delete () (interactive) (let ((undo (jao-notmuch--has-tag "deleted"))) - (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo nil))) + (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo))) -(defun jao-notmuch-tree-toggle-delete-thread () - (interactive) +(defun jao-notmuch-tree-toggle-delete-thread (full) + (interactive "P") (let ((undo (jao-notmuch--has-tag "deleted"))) - (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo t))) + (jao-notmuch-tree-tag-thread '("+deleted" "-new" "-unread") undo full))) -(defun jao-notmuch-tree-read-thread (unread) +(defun jao-notmuch-tree-read-thread (full) (interactive "P") - (jao-notmuch-tree--tag-and-next '("-unread" "-new") unread t)) + (jao-notmuch-tree-tag-thread '("-unread" "-new") nil full)) (defun jao-notmuch-tree-toggle-flag () (interactive) (let ((tags (if (jao-notmuch--has-tag "flagged") '("-flagged") '("-unread" "-new" "-deleted" "+flagged")))) - (jao-notmuch-tree--tag-and-next tags nil nil))) + (jao-notmuch-tree--tag-and-next tags nil))) (defun jao-notmuch-tree-toggle-spam () (interactive) (let ((tags (if (jao-notmuch--has-tag "spam") '("-spam") '("-unread" "-new" "+spam")))) - (jao-notmuch-tree--tag-and-next tags nil nil))) + (jao-notmuch-tree--tag-and-next tags nil))) (defun jao-notmuch-tree-reset-tags () (interactive) (let ((tags (plist-get (notmuch-tree-get-message-properties) :orig-tags))) - (jao-notmuch-tree--tag tags nil nil) - (jao-notmuch-tree--next nil nil t t))) - - -;;;; Results formatters + (jao-notmuch-tree--tag tags nil))) + +;;; fcc +(defvar jao-notmuch-mua-reply-not-inherited + '("attachment" "sent" "new" "bigml" "jao" "trove")) + +(defun jao-notmuch-mua--fcc-dirs () + (let* ((otags (notmuch-show-get-tags)) + (trove (or (seq-some (lambda (x) (and (member x otags) x)) + '("hacking" "bills" "feeds" "jao")) + "jao")) + (tags (seq-difference otags jao-notmuch-mua-reply-not-inherited)) + (tagstr (mapconcat (lambda (s) (concat "+" s)) tags " ")) + (fcc (concat "trove/" trove " " tagstr " -new +sent +trove")) + (fcc-dirs (assoc-delete-all ".*" (copy-alist notmuch-fcc-dirs)))) + (append fcc-dirs `((".*" . ,fcc))))) + +(defun jao-notmuch-mua--inherited-fcc () + (let* ((fn (notmuch-show-get-filename)) + (dest (and (string-match ".*/var/mail/\\(.+?\\)/.+" fn) + (match-string 1 fn))) + (tags (seq-difference (notmuch-show-get-tags) + '("attachment" "sent" "new" "flagged"))) + (tagstr (mapconcat (lambda (s) (concat "+" s)) tags " ")) + (fcc (concat dest " " tagstr " -new +sent +trove")) + (fcc-dirs (assoc-delete-all ".*" (copy-alist notmuch-fcc-dirs)))) + (append fcc-dirs `((".*" . ,fcc))))) + +(defun jao-notmuch-mua-new-reply (fun &rest args) + (let ((notmuch-fcc-dirs (and (not (notmuch-show-get-header :List-Id)) + (jao-notmuch-mua--inherited-fcc)))) + (apply fun args))) + +(advice-add 'notmuch-mua-new-reply :around #'jao-notmuch-mua-new-reply) + +;;; results formatters + +(defun jao-notmuch-cmp-tags (a b) + (or (> (length a) (length b)) (string-lessp a b))) (defun jao-notmuch-format-tags (fmt msg) (let ((ts (thread-last (notmuch-tree-format-field "tags" "%s" msg) (split-string) - (seq-sort-by #'length #'<)))) + ;; (seq-sort-by #'length #'<) + (seq-sort #'jao-notmuch-cmp-tags)))) (format-spec fmt `((?s . ,(mapconcat #'identity ts " ")))))) -(defun jao-notmuch-tree-and-subject (fmt msg) +(defun jao-notmuch-format-tree-and-subject (fmt msg) (let ((tr (notmuch-tree-format-field "tree" " %s" msg)) (sb (notmuch-tree-format-field "subject" " %s" msg))) (format-spec fmt `((?s . ,(concat tr sb)))))) -(defun jao-notmuch-msg-ticks (mails-rx msg) +(defun jao-notmuch-format-msg-ticks (mails-rx msg) (let ((headers (plist-get msg :headers))) (cond ((string-match-p mails-rx (or (plist-get headers :To) "")) (propertize " ยป" 'face 'notmuch-tree-match-tree-face)) diff --git a/lib/net/jao-proton-utils.el b/lib/net/jao-proton-utils.el new file mode 100644 index 0000000..62b97b3 --- /dev/null +++ b/lib/net/jao-proton-utils.el @@ -0,0 +1,141 @@ +;; jao-proton-utils.el -- simple interaction with Proton mail and vpn + +;; Copyright (c) 2018, 2019, 2020, 2023 Jose Antonio Ortega Ruiz + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Start date: Fri Dec 21, 2018 23:56 + +;;; Comentary: + +;; This is a very simple comint-derived mode to run the CLI version +;; of PM's Bridge within the comfort of emacs. + +;;; Code: + +(define-derived-mode proton-bridge-mode comint-mode "proton-bridge" + "A very simple comint-based mode to run ProtonMail's bridge" + (setq comint-prompt-read-only t) + (setq comint-prompt-regexp "^>>> ")) + +;;;###autoload +(defun run-proton-bridge () + "Run or switch to an existing bridge process, using its CLI" + (interactive) + (pop-to-buffer (make-comint "proton-bridge" "protonmail-bridge" nil "-c")) + (unless (eq major-mode 'proton-bridge-mode) + (proton-bridge-mode))) + +;;;###autoload +(defun proton-bridge-sendmail-setup () + "Configure message sending for local proton bridge." + (setq send-mail-function #'smtpmail-send-it) + (setq message-send-mail-function #'smtpmail-send-it) + (setq smtpmail-servers-requiring-authorization + (regexp-opt '("localhost" "127.0.0.1"))) + (setq smtpmail-auth-supported '(plain login)) + (setq smtpmail-smtp-user "mail@jao.io") + (setq smtpmail-smtp-server "localhost") + (setq smtpmail-smtp-service 1025)) + +(defvar jao-proton-vpn-font-lock-keywords '("\\[.+\\]")) + +;;;###autoload +(defun proton-vpn-mode () + "A very simple mode to show the output of ProtonVPN commands" + (interactive) + (kill-all-local-variables) + (buffer-disable-undo) + (use-local-map proton-vpn-mode-map) + (setq-local font-lock-defaults '(jao-proton-vpn-font-lock-keywords)) + (setq-local truncate-lines t) + (setq-local next-line-add-newlines nil) + (setq major-mode 'proton-vpn-mode) + (setq mode-name "proton-vpn") + (read-only-mode 1)) + +(defvar jao-proton-vpn--buffer "*pvpn*") + +(defun jao-proton-vpn--do (things) + (let ((b (pop-to-buffer (get-buffer-create jao-proton-vpn--buffer)))) + (let ((inhibit-read-only t) + (cmd (format "protonvpn-cli %s" things))) + (delete-region (point-min) (point-max)) + (message "Running: %s ...." cmd) + (shell-command cmd b) + (message "")) + (proton-vpn-mode))) + +;;;###autoload +(defun proton-vpn-status () + (interactive) + (jao-proton-vpn--do "s")) + +(defun proton-vpn--get-status () + (or (when-let ((b (get-buffer jao-proton-vpn--buffer))) + (with-current-buffer b + (goto-char (point-min)) + (if (re-search-forward "^Status: *\\(.+\\)$" nil t) + (match-string-no-properties 1) + (when (re-search-forward "^Connected!$") + "Connected")))) + "Disconnected")) + +;;;###autoload +(defun proton-vpn-connect (cc) + (interactive "P") + (let ((cc (when cc (read-string "Country code: ")))) + (jao-proton-vpn--do (if cc (format "c --cc %s" cc) "c --sc")) + (proton-vpn-status))) + +(defun proton-vpn-reconnect () + (interactive) + (jao-proton-vpn--do "r")) + +(setenv "PVPN_WAIT" "300") + +;;;###autoload +(defun proton-vpn-maybe-reconnect () + (interactive) + (when (string= "Connected" (proton-vpn--get-status)) + (jao-proton-vpn--do "d") + (sit-for 5) + (jao-proton-vpn--do "r"))) + +;;;###autoload +(defun proton-vpn-disconnect () + (interactive) + (jao-proton-vpn--do "d")) + +(setq proton-vpn-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map [?q] 'bury-buffer) + (define-key map [?n] 'next-line) + (define-key map [?p] 'previous-line) + (define-key map [?g] 'proton-vpn-status) + (define-key map [?r] 'proton-vpn-reconnect) + (define-key map [?d] (lambda () + (interactive) + (when (y-or-n-p "Disconnect?") + (proton-vpn-disconnect)))) + (define-key map [?c] 'proton-vpn-connect) + map)) + + +(provide 'jao-proton-utils) +;;; jao-proton.el ends here diff --git a/lib/net/signel.org b/lib/net/signel.org deleted file mode 100644 index 722069c..0000000 --- a/lib/net/signel.org +++ /dev/null @@ -1,546 +0,0 @@ -#+title: signel, a barebones signal chat on top of signal-cli -#+date: <2020-02-23 05:03> -#+filetags: emacs norss -#+PROPERTY: header-args :tangle yes :comments yes :results silent - -Unlike most chat systems in common use, [[https://signal.org][Signal]] lacks a decent emacs -client. All i could find was [[https://github.com/mrkrd/signal-msg][signal-msg]], which is able only to send -messages and has a readme that explicitly warns that its is /not/ a chat -application. Skimming over signal-msg's code i learnt about -[[https://github.com/AsamK/signal-cli][signal-cli]], a java-based daemon that knows how to send and receive -signal messages, and how to link to a nearby phone, or register new -users. And playing with it i saw that it can output its activities -formatted as JSON, and that offers (when run in daemon mode) a DBUS -service that can be used to send messages. - -Now, emacs knows how to run a process and capture its output handling -it to a filter function, and comes equipped with a JSON parser and -a set of built-in functions to talk to DBUS buses. - -So how about writing a simple Signal chat app for emacs? Let's call it -/signel/, and write it as [[https://gitlab.com/jaor/elibs/-/blob/master/net/signel.org][a blog post in literate org-mode]]. - -* Starting a process - -We are going to need a variable for our identity (telephone number), -and a list of contact names (until i discover how to get them directly -from signal-cli): - -#+begin_src emacs-lisp -(require 'cl-lib) - -(defvar signel-cli-user "+44744xxxxxx") -(defvar signel-contact-names '(("+447xxxxxxxx" . "john") - ("+346xxxxxxxx" . "anna"))) -#+end_src - -and a simple function to get a contact name given its telephone -number: - -#+begin_src emacs-lisp -(defun signel--contact-name (src) - (or (alist-get src signel-contact-names nil nil #'string-equal) src)) -#+end_src - -We are also going to need the path for our signal-cli executable - -#+begin_src emacs-lisp -(defvar signel-cli-exec "signal-cli") -#+end_src - -Starting the signal-cli process is easy: ~make-process~ provides all the -necessary bits. What we need is essentially calling - -#+begin_src shell -signal-cli -u +44744xxxxxx daemon --json -#+end_src - -associating to the process a buffer selected by the function -~signel--proc-buffer~ . While we are at it, we'll write also little -helpers for users of our API. - -#+begin_src emacs-lisp -(defun signel--proc-buffer () - (get-buffer-create "*signal-cli*")) - -(defun signel-signal-cli-buffer () - (get-buffer "*signal-cli*")) - -(defun signel-signal-cli-process () - (when-let ((proc (get-buffer-process (signel-signal-cli-buffer)))) - (and (process-live-p proc) proc))) -#+end_src - -#+begin_src emacs-lisp -(defun signel-start () - "Start the underlying signal-cli process if needed." - (interactive) - (if (signel-signal-cli-process) - (message "signal-cli is already running!") - (let ((b (signel--proc-buffer))) - (make-process :name "signal-cli" - :buffer b - :command `(,signel-cli-exec - "-u" - ,signel-cli-user - "daemon" "--json") - :filter #'signel--filter) - (message "Listening to signals!")))) -#+end_src - -* Parsing JSON - -We've told emacs to handle any ouput of the process to the function -~signel--filter~, which we're going to write next. This function will -receive the process object and its latest output as a string -representing a JSON object. Here's an example of the kind of outputs -that signal-cli emits: - -#+begin_src json :tangle no -{ - "envelope": { - "source": "+4473xxxxxxxx", - "sourceDevice": 1, - "relay": null, - "timestamp": 1582396178696, - "isReceipt": false, - "dataMessage": { - "timestamp": 1582396178696, - "message": "Hello there!", - "expiresInSeconds": 0, - "attachments": [], - "groupInfo": null - }, - "syncMessage": null, - "callMessage": null, - "receiptMessage": null - } -} -#+end_src - -Everything seems to be always inside ~envelope~, which contains objects -for the possible messages received. In the example above, we're -receiving a message from a /source/ contact. We can also receive -receipt messages, telling us whether our last message has been -received or read; e.g.: - -#+begin_src json :tangle no -{ - "envelope": { - "source": "+4473xxxxxxxx", - "sourceDevice": 1, - "relay": null, - "timestamp": 1582397117584, - "isReceipt": false, - "dataMessage": null, - "syncMessage": null, - "callMessage": null, - "receiptMessage": { - "when": 1582397117584, - "isDelivery": true, - "isRead": false, - "timestamps": [ - 1582397111524 - ] - } - } -} -#+end_src - -A bit confusingly, that delivery notification has a ~receiptMessage~, -but its ~isReceipt~ flag is set to ~false~. At other times, we get -~isReceipt~ but no ~receiptMessage~: - -#+begin_src json :tangle no -{ - "envelope": { - "source": "+346xxxxxxxx", - "sourceDevice": 1, - "relay": null, - "timestamp": 1582476539281, - "isReceipt": true, - "dataMessage": null, - "syncMessage": null, - "callMessage": null, - "receiptMessage": null - } -} -#+end_src - -It is very easy to parse JSON in emacs and extract signal-cli's -envelopes (and it's become faster in emacs 27, but the interface is a -bit different): - -#+begin_src emacs-lisp -(defun signel--parse-json (str) - (if (> emacs-major-version 26) - (json-parse-string str - :null-object nil - :false-object nil - :object-type 'alist - :array-type 'list) - (json-read-from-string str))) - -(defun signel--msg-contents (str) - (alist-get 'envelope (ignore-errors (signel--parse-json str)))) -#+end_src - -Here i am being old-school and opting to receive JSON dicitionaries as -alists (rather than hash maps, the default), and arrays as lists -rather than vectors just because lisps are lisps for a reason. I'm -also going to do some mild [[https://lispcast.com/nil-punning/][nil punning]], -hence the choice for null and false representations. - -Once the contents of the envelope is extracted, it's trivial (and -boring) to get into its components: - -#+begin_src emacs-lisp -(defun signel--msg-source (msg) (alist-get 'source msg)) - -(defun signel--msg-data (msg) - (alist-get 'message (alist-get 'dataMessage msg))) - -(defun signel--msg-timestamp (msg) - (if-let (msecs (alist-get 'timestamp msg)) - (format-time-string "%H:%M" (/ msecs 1000)) - "")) - -;; emacs 26 compat -(defun signel--not-false (x) - (and (not (eq :json-false x)) x)) - -(defun signel--msg-receipt (msg) - (alist-get 'receiptMessage msg)) - -(defun signel--msg-is-receipt (msg) - (signel--not-false (alist-get 'isReceipt msg))) - -(defun signel--msg-receipt-timestamp (msg) - (when-let (msecs (alist-get 'when (signel--msg-receipt msg))) - (format-time-string "%H:%M" (/ msecs 1000)))) - -(defun signel--msg-is-delivery (msg) - (when-let ((receipt (signel--msg-receipt msg))) - (signel--not-false (alist-get 'isDelivery msg)))) - -(defun signel--msg-is-read (msg) - (when-let ((receipt (signel--msg-receipt msg))) - (signel--not-false (alist-get 'isRead msg)))) -#+end_src - -* A process output filter - -We're almost ready to write our filter. It will: - -- For debugging purposes, insert the raw JSON string in the process - buffer. -- Parse the received JSON string and extract its envelope contents. -- Check wether it has a source and either message data or a receipt - timestamp. -- Dispatch to a helper function that will insert the data or - notification in a chat buffer. - -Or, in elisp: - -#+begin_src emacs-lisp -(defvar signel--line-buffer "") - -(defun signel--filter (proc str) - (signel--ordinary-insertion-filter proc str) - (let ((str (concat signel--line-buffer str))) - (if-let ((msg (signel--msg-contents str))) - (let ((source (signel--msg-source msg)) - (stamp (signel--msg-timestamp msg)) - (data (signel--msg-data msg)) - (rec-stamp (signel--msg-receipt-timestamp msg))) - (setq signel--line-buffer "") - (when source - (signel--update-chat-buffer source data stamp rec-stamp msg))) - (setq signel--line-buffer - (if (string-match-p ".*\n$" str) "" str))))) -#+end_src - -We've had to take care of the case when the filter receives input that -is not a complete JSON expression: in the case of signal-cli, that -only happens when we haven't seen yet an end of line. - -The function to insert the raw contents in the process buffer is -surprisingly hard to get right, but the emacs manual spells out a -reasonable implementation, which i just copied: - -#+begin_src emacs-lisp -(defun signel--ordinary-insertion-filter (proc string) - (when (and proc (buffer-live-p (process-buffer proc))) - (with-current-buffer (process-buffer proc) - (let ((moving (= (point) (process-mark proc)))) - (save-excursion - ;; Insert the text, advancing the process marker. - (goto-char (process-mark proc)) - (insert string) - (set-marker (process-mark proc) (point))) - (if moving (goto-char (process-mark proc))))))) -#+end_src - -* It's not an emacs app if it doesn't have a new mode - -With that out of the way, we just have to insert our data in an -appropriate buffer. We are going to associate a separate buffer to -each /source/, using for that its name: - -#+begin_src emacs-lisp -(defvar-local signel-user nil) - -(defun signel--contact-buffer (source) - (let* ((name (format "*%s" (signel--contact-name source))) - (buffer (get-buffer name))) - (unless buffer - (setq buffer (get-buffer-create name)) - (with-current-buffer buffer - (signel-chat-mode) - (setq-local signel-user source) - (insert signel-prompt))) - buffer)) -#+end_src - -where, as is often the case in emacs, we are going to have a dedicated -major mode for chat buffers, called ~signel-chat-mode~. For now, let's -keep it really simple (for the record, this is essentially a copy of -what ERC does for its erc-mode): - -#+begin_src emacs-lisp -(defvar signel-prompt ": ") - -(define-derived-mode signel-chat-mode fundamental-mode "Signal" - "Major mode for Signal chats." - (when (boundp 'next-line-add-newlines) - (set (make-local-variable 'next-line-add-newlines) nil)) - (setq line-move-ignore-invisible t) - (set (make-local-variable 'paragraph-separate) - (concat "\C-l\\|\\(^" (regexp-quote signel-prompt) "\\)")) - (set (make-local-variable 'paragraph-start) - (concat "\\(" (regexp-quote signel-prompt) "\\)")) - (setq-local completion-ignore-case t)) -#+end_src - -Note how, in ~signel--contact-buffer~, we're storing the user identity -associated with the buffer (its /source/) in a buffer-local variable -named ~signel-user~ that is set /after/ enabling ~signel-chat-mode~: order -here matters because the major mode activation cleans up the values of -any local variables previously set (i always forget that!). - -* And a customization group - -We're going to need a couple of new faces for the different parts of -inserted messages, so we'll take the chance to be tidy and introduce a -customization group: - -#+begin_src emacs-lisp -(defgroup signel nil "Signel") - -(defface signel-contact '((t :weight bold)) - "Face for contact names." - :group 'signel) - -(defface signel-timestamp '((t :foreground "grey70")) - "Face for timestamp names." - :group 'signel) - -(defface signel-notice '((t :inherit signel-timestamp)) - "Face for delivery notices." - :group 'signel) - -(defface signel-prompt '((t :weight bold)) - "Face for the input prompt marker." - :group 'signel) - -(defface signel-user '((t :foreground "orangered")) - "Face for sent messages." - :group 'signel) - -(defface signel-notification '((t :foreground "burlywood")) - "Face for notifications shown by tracking, when available." - :group 'signel) - -#+end_src - - -* Displaying incoming messages - -We have now almost all the ingredients to write -~signel--update-chat-buffer~, the function that inserts the received -message data into the chat buffer. Let's define a few little -functions to format those parts: - -#+begin_src emacs-lisp -(defun signel--contact (name) - (propertize name 'face 'signel-contact)) - -(defun signel--timestamp (&rest p) - (propertize (apply #'concat p) 'face 'signel-timestamp)) - -(defun signel--notice (notice) - (propertize notice 'face 'signel-notice)) - -(defun signel--insert-prompt () - (let ((inhibit-read-only t) - (p (point))) - (insert signel-prompt) - (set-text-properties p (- (point) 1) - '(face signel-prompt - read-only t front-sticky t rear-sticky t)))) - -(defun signel--delete-prompt () - (when (looking-at-p (regexp-quote signel-prompt)) - (let ((inhibit-read-only t)) - (delete-char (length signel-prompt))))) - -(defun signel--delete-last-prompt () - (goto-char (point-max)) - (when (re-search-backward (concat "^" (regexp-quote signel-prompt))) - (signel--delete-prompt))) - -#+end_src - -With that, we're finally ready to insert messages in our signel chat -buffers: - -#+begin_src emacs-lisp -(defcustom signel-report-deliveries nil - "Whether to show message delivery notices." - :group 'signel - :type 'boolean) - -(defcustom signel-report-read t - "Whether to show message read notices." - :group 'signel - :type 'boolean) - -(defun signel--prompt-and-notify () - (signel--insert-prompt) - (when (fboundp 'tracking-add-buffer) - (tracking-add-buffer (current-buffer) '(signel-notification)))) - -(defun signel--needs-insert-p (data stamp rec-stamp msg) - (or data - (and (or rec-stamp stamp) - (not (string= source signel-cli-user)) - (or signel-report-deliveries - (and signel-report-read (signel--msg-is-read msg)))))) - -(defun signel--update-chat-buffer (source data stamp rec-stamp msg) - (when (signel--needs-insert-p data stamp rec-stamp msg) - (when-let ((b (signel--contact-buffer source))) - (with-current-buffer b - (signel--delete-last-prompt) - (if data - (let ((p (point))) - (insert (signel--timestamp "[" stamp "] ") - (signel--contact (signel--contact-name source)) - signel-prompt - data - "\n") - (fill-region p (point))) - (let ((is-read (signel--msg-is-read msg))) - (insert (signel--timestamp "*" (or rec-stamp stamp) "* ") - (signel--notice (if is-read "(read)" "(delivered)")) - "\n"))) - (signel--prompt-and-notify) - (end-of-line))))) -#+end_src - -There are some rough edges in the above implementation that must be -polished should signel ever be released in the wild. For one, proper -handling of timestamps and their formats. And of course notifications -should be much more customizable (here i'm using [[https://github.com/jorgenschaefer/circe/blob/master/tracking.el][Circe's tracking.el]] -if available). - -* Sending messages: the DBUS interface - -With that, we're going to receive and display messages and simple -receipts, and i'm sure that we will feel the urge to answer some of -them. As mentioned above, signal-cli let's us send messages via its -[[https://github.com/AsamK/signal-cli/wiki/DBus-service][DBUS interface]]. -In a nutshell, if you want to send ~MESSAGETEXT~ to a -~RECIPIENT~ you'd invoke something like: - -#+begin_src shell :tangle no -dbus-send --session --type=method_call \ - --dest="org.asamk.Signal" \ - /org/asamk/Signal \ - org.asamk.Signal.sendMessage \ - string:MESSAGETEXT array:string: string:RECIPIENT -#+end_src - -That is, call the method ~sendMessage~ of the corresponding service -interface with three arguments (the second one empty). Using emacs' -dbus libray one can write the above as: - -#+begin_src emacs-lisp -(defun signel--send-message (user msg) - (dbus-call-method :session "org.asamk.Signal" "/org/asamk/Signal" - "org.asamk.Signal" "sendMessage" - :string msg - '(:array) - :string user)) -#+end_src - -The only complicated bit is being careful with the specification of -the types of the method arguments: if one gets them wrong, DBUS will -simply complain and say that the method is not defined, which was -confusing me at first (but of course makes sense because DBUS allows -overloading method names, so the full method spec must include its -signature). - -We want to read whatever our user writes after the last prompt and -send it via the little helper above. Here's our interactive command -for that: - -#+begin_src emacs-lisp -(defun signel-send () - "Read text inserted in the current buffer after the last prompt and send it. - -The recipient of the message is looked up in a local variable set -when the buffer was created." - (interactive) - (goto-char (point-max)) - (beginning-of-line) - (let* ((p (point)) - (plen (length signel-prompt)) - (msg (buffer-substring (+ p plen) (point-max)))) - (signel--delete-prompt) - (signel--send-message signel-user msg) - (insert (signel--timestamp (format-time-string "(%H:%M) "))) - (fill-region p (point-max)) - (goto-char (point-max)) - (set-text-properties p (point) '(face signel-user)) - (insert "\n") - (signel--insert-prompt))) -#+end_src - -and we can bind it to the return key in signal chat buffers: - -#+begin_src emacs-lisp -(define-key signel-chat-mode-map "\C-m" #'signel-send) -#+end_src - -And we are going sometimes to want to talk to contacts that don't have -yet said anything and have, therefore, no associated chat buffer: - -#+begin_src emacs-lisp -(defun signel-query (contact) - "Start a conversation with a signal contact." - (interactive (list (completing-read "Signal to: " - (mapcar #'cdr-safe signel-contact-names)))) - (let ((phone (alist-get contact - (cl-pairlis (mapcar #'cdr signel-contact-names) - (mapcar #'car signel-contact-names)) - nil nil #'string-equal))) - (when (not phone) - (error "Unknown contact %s" contact)) - (pop-to-buffer (signel--contact-buffer phone)))) -#+end_src - -There are of course lots of rough edges and missing functionality in -this incipient signel, but it's already usable and a nice -demonstration of how easy it is to get the ball rolling in this lisp -machine of ours! |