├── .gitignore ├── README.org ├── bic-bbdb.el ├── bic-core.el ├── bic-mailbox-tree.el ├── bic-mailbox.el ├── bic-message.el ├── bic-org.el ├── bic-smtpmail.el └── bic.el /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | *~ 3 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+STARTUP: showall 2 | 3 | * BIC, the Best IMAP Client 4 | 5 | BIC is an IMAP client for Emacs. It is built on the following 6 | principles: 7 | 8 | - *asynchronicity*: the Emacs user interface should be blocked as 9 | little as possible. Any long-running commands should be run in the 10 | background. 11 | - *minimal configuration*: you should be able to /just read 12 | your mail/ without adding half a page of configuration variable 13 | settings to your =.emacs= file, or installing and configuring any 14 | external programs. /Life is too short./ 15 | - *offline is online*: the client should have the same behaviour even 16 | if the connection to the mail server is lost, and changes should be 17 | synchronised seamlessly once the connection is reestablished. 18 | - *osmosis*: you shouldn't have to ask your mail client to download 19 | your messages for offline access; they should just be available 20 | without you having to do anything. 21 | 22 | That said, it is still a work in progress. See "Known problems" 23 | below. 24 | 25 | ** Who, if not you? When, if not now? 26 | 27 | Of course, there is no such thing as a "Best IMAP Client"; that 28 | depends on far too many factors. BIC is a snapshot in time and space: 29 | it's the intersection of what is possible in Emacs 25.1, what is 30 | possible considering the principles I stated above, and what I had the 31 | time and energy to implement. 32 | 33 | In a way, BIC is defined more by what it isn't than by what it is: it 34 | isn't Gnus, which blocks when communicating with the server, and it 35 | isn't mu4e, which requires =mu= and =offlineimap= to be installed. 36 | 37 | So what will BIC become in the future? Hard to tell. It has basic 38 | functionality, though many features you'd expect in an email client 39 | are missing (see "Known problems"). I may or may not have the time 40 | and energy to "complete" the work. Maybe the principles BIC is based 41 | on will be irrelevant: will the IMAP protocol still be used? will 42 | reading email in Emacs still be a desirable thing? will the concept 43 | of email change beyond recognition? 44 | 45 | What I want to say with this is that the future of BIC is in your 46 | hands. Do you think that BIC is useful or meaningful, that the basic 47 | ideas and concepts are helpful? If so, maybe you are the chosen one 48 | to make BIC better. [[https://github.com/legoscia/bic/issues][Create an issue]] on GitHub with your thoughts, 49 | ideas and questions. 50 | 51 | ** Requirements 52 | 53 | BIC requires *Emacs 25*, nothing less. Emacs 25.1 was released on 54 | 2016-09-17. 55 | 56 | BIC also requires the packages [[https://elpa.gnu.org/packages/fsm.html][fsm (from GNU ELPA)]] and [[http://melpa.org/#/srv][srv (from 57 | MELPA)]] to be installed. 58 | 59 | BIC has not been tested on Windows, so any reports, positive or 60 | negative, are very welcome. 61 | 62 | ** How to use 63 | 64 | Type =M-x package-install-file=, and enter the _directory_ where 65 | bic.el etc are found. 66 | 67 | Then type =M-x bic=. If it's the first time you use BIC, it will ask 68 | for your email address and IMAP server. Otherwise, it will just start 69 | BIC with the previously configured account. (If you want to add 70 | another account, type =M-x bic-add-account=.) 71 | 72 | For any mailbox you open, BIC will download all messages that are less 73 | than 30 days old, and all messages that are unread or flagged 74 | regardless of date. 75 | 76 | The key bindings are mostly based on Gnus. See =C-h m= for the 77 | corresponding buffer for more information. 78 | 79 | ** How to stop using it 80 | 81 | If you just want to stay disconnected for a while, use =M-x 82 | bic-deactivate= or =M-x bic-deactivate-all=, and then use =M-x 83 | bic-activate= or =M-q bic-activate-all= when you want to reconnect. 84 | 85 | If you want to stop BIC, type =M-x bic-stop= for each account you have 86 | added, or =M-x bic-stop-all= to stop all accounts. All downloaded 87 | data is stored in the =~/.emacs.d/bic= directory; you can remove that 88 | if you want. 89 | 90 | ** Known problems 91 | 92 | - At the moment, it only downloads messages from your inbox 93 | automatically. For other mailboxes, messages are downloaded when 94 | you open that mailbox. (This does not apply if your IMAP server 95 | supports NOTIFY.) You can use =M-x bic-list-status-all= to 96 | explicitly sync all subscribed mailboxes. 97 | - The unread message count in the mailbox tree view is currently 98 | only updated when you explicity request a status update. 99 | - It's too verbose, showing too many messages in the echo area. 100 | - There is currently no way to access messages older than 30 days, 101 | unless they are unread or flagged. 102 | - If a large number of messages has been downloaded for a certain 103 | mailbox, opening that mailbox will take a long time. 104 | - It doesn't detect that messages have been deleted on the server. 105 | - There is currently no way to copy or move messages. 106 | - Messages are not threaded. 107 | - There is no search function. 108 | - If the server doesn't support =IDLE=, messages will be downloaded 109 | rather infrequently. 110 | - If you enter the wrong password, BIC will repeatedly try to connect 111 | using the incorrect password until you run =M-x 112 | auth-source-forget-all-cached=. 113 | - While BIC attempts to open connections asynchronously, on some 114 | systems Emacs performs DNS requests synchronously. This can 115 | sometimes lead to the user interface being blocked while BIC tries 116 | to reconnect to the server. There was [[https://lists.gnu.org/archive/html/emacs-devel/2015-02/msg00830.html][a thread about this on 117 | emacs-devel]], and [[https://lists.gnu.org/archive/html/emacs-devel/2016-01/msg01348.html][another one]]. 118 | 119 | For GNU/Linux, support for asynchronous DNS resolution was 120 | introduced in Emacs 26.1. 121 | 122 | For OS X, asynchronous DNS is not yet supported. See 123 | [[https://lists.gnu.org/archive/html/emacs-devel/2016-05/msg00526.html][this emacs-devel thread]]. 124 | - While Emacs supports making GnuTLS perform TLS handshakes 125 | asynchronously, BIC somehow doesn't manage to make use of that. 126 | Need to investigate. 127 | 128 | ** Troubleshooting 129 | 130 | If something goes wrong, there are four places where you may want to 131 | look for more information: 132 | 133 | - The =*bic-transcript-username@example.com*= buffer contains a 134 | transcript of IMAP requests and responses exchanged with the 135 | server. When copying text from the transcript buffer to another 136 | buffer, BIC makes an effort to remove information you might not 137 | want to share, such as email addresses and subject lines. 138 | - The =*Warnings*= buffer contains warnings about unexpected events. 139 | - The =*fsm-debug*= buffer shows messages and state transitions for 140 | the state machines. This is usually uninteresting, except for the 141 | messages that contain "warning" or "error". 142 | - Currently, the =*Messages*= buffer gets more than its fair share of 143 | various more or less informative messages. 144 | 145 | If BIC makes Emacs slow, try profiling it to find out which part of 146 | the code needs to be optimised: 147 | 148 | - =M-x profiler-start= 149 | - Do whatever makes Emacs slow. 150 | - =M-x profiler-report= 151 | - Afterwards, deactivate profiling with =M-x profiler-stop=. 152 | 153 | ** What about sending email? 154 | Note that BIC is the Best IMAP Client, not the Best SMTP Client =:)= 155 | You should look into the =smtpmail= library that is included with 156 | Emacs. 157 | 158 | BIC can integrate with smtpmail, to make it queue outgoing messages 159 | while you're offline, and send them automatically when you come online 160 | again. To enable that behaviour, set =bic-smtpmail-toggle-queueing= 161 | to =t=. 162 | 163 | ** Contact 164 | 165 | Feel free to open an issue in [[https://github.com/legoscia/bic/issues][the issue tracker]], or send me an email 166 | at =magnus.henoch@gmail.com=. 167 | -------------------------------------------------------------------------------- /bic-bbdb.el: -------------------------------------------------------------------------------- 1 | ;;; bic-bbdb.el --- BBDB bindings for BIC -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2015 Magnus Henoch 4 | 5 | ;; Author: Magnus Henoch 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Bind `:' in bic-message-mode to bring up BBDB records for the 23 | ;; current message. 24 | ;; 25 | ;; Insinuate BBDB to understand what BIC is about. 26 | 27 | ;;; Code: 28 | 29 | ;; Defined in bbdb-mua. 30 | (defvar bbdb-mua-mode-alist) 31 | 32 | ;;;###autoload 33 | (with-eval-after-load "bbdb-mua" 34 | ;; Need to tell BBDB what kind of mail client we are. 35 | ;; `message' is close enough, so add `bic-message-mode' as one of 36 | ;; the major modes that trigger "message" treatment. 37 | (let ((message-entry (assq 'message bbdb-mua-mode-alist))) 38 | (cl-pushnew 'bic-message-mode (cdr message-entry)))) 39 | 40 | ;;;###autoload 41 | (with-eval-after-load "bic-message" 42 | (define-key bic-message-mode-map ":" 'bbdb-mua-display-all-records)) 43 | 44 | (provide 'bic-bbdb) 45 | ;;; bic-bbdb.el ends here 46 | -------------------------------------------------------------------------------- /bic-core.el: -------------------------------------------------------------------------------- 1 | ;;; bic-core.el --- core of the Best IMAP Client -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2013 Magnus Henoch 4 | 5 | ;; Author: Magnus Henoch 6 | ;; Keywords: mail 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (require 'cl-lib) 28 | (require 'fsm) 29 | (require 'sasl) 30 | (require 'gnutls) 31 | (require 'auth-source) 32 | (require 'password-cache) 33 | 34 | (defvar bic-transcript-buffer "*bic-transcript-%s*") 35 | 36 | (defvar bic-redact-transcript t 37 | "Hide addresses, subject lines and message ids in transcript.") 38 | 39 | (defvar bic-ignore-tls-errors nil 40 | "If non-nil, ignore certificate verification errors.") 41 | 42 | (defvar bic-send-cleartext-password nil 43 | "If non-nil, allow sending passwords on unencrypted connections.") 44 | 45 | (defvar bic-ignored-capabilities nil 46 | "Pretend that the server doesn't advertise these capabilities. 47 | This should be a list of strings. For debugging only.") 48 | 49 | (defvar-local bic--issued-markers nil 50 | "Hash table of markers issued from current buffer. 51 | Ideally, this should be a weak ordered list, but since Emacs Lisp 52 | doesn't have that, we use a weak hash table instead.") 53 | 54 | (defvar-local bic--next-issued-marker 0 55 | "The key for the next marker to be issued.") 56 | 57 | (defvar-local bic--next-collected-marker 0 58 | "Start looking at this key for markers to collect.") 59 | 60 | (define-state-machine bic-connection 61 | :start ((username server connection-type 62 | &optional port callback auth-wait untagged-callback) 63 | "Start an IMAP connection. 64 | USERNAME is the username to authenticate as. 65 | SERVER is the server to connect to. 66 | CONNECTION-TYPE is one of the following: 67 | - :starttls, connect to port 143 and request encryption 68 | - :plaintls, connect to port 993 and encrypt from the start 69 | - :unencrypted, connect to port 143 without encrypting 70 | PORT, if given, overrides the port derived from CONNECTION-TYPE. 71 | 72 | CALLBACK, if given, should be a function taking two arguments. 73 | The first argument is always the FSM (can be compared with `eq'). 74 | It will be called with :authenticated as the second argument once 75 | authentication has completed successfully. It will also be 76 | called with \(:disconnected KEYWORD REASON-STRING\) when the 77 | connection is closed. 78 | 79 | If AUTH-WAIT is provided and non-nil, we establish an encrypted 80 | connection, but don't proceed with authentication immediately. 81 | The CALLBACK will be called with a second argument of :auth-wait, 82 | and the caller needs to send :proceed using `fsm-send' to 83 | proceed. 84 | 85 | If UNTAGGED-CALLBACK is provided and non-nil, any untagged 86 | responses not explicitly handled will be passed to this function. 87 | It should take one argument, the line parsed as a list of tokens, 88 | omitting the leading \"*\"." 89 | (list :connecting 90 | (list :name (concat username "@" server) 91 | :username username 92 | :server server 93 | :port port 94 | :connection-type connection-type 95 | :callback (or callback #'ignore) 96 | :auth-wait auth-wait 97 | :untagged-callback untagged-callback)))) 98 | 99 | (define-enter-state bic-connection :connecting 100 | (fsm state-data) 101 | (let* ((server (plist-get state-data :server)) 102 | (connection-type (plist-get state-data :connection-type)) 103 | (service (or (plist-get state-data :port) 104 | (cl-ecase connection-type 105 | ((:starttls :unencrypted) 143) 106 | (:plaintls 993)))) 107 | (buffer-name (concat " bic-" server "-" (plist-get state-data :username))) 108 | (buffer (generate-new-buffer buffer-name))) 109 | (condition-case e 110 | (let ((proc (make-network-process 111 | :name (concat "bic-" server "-" (plist-get state-data :username)) 112 | :buffer buffer 113 | :host server 114 | :service service 115 | :coding 'binary 116 | :nowait t 117 | :keepalive t 118 | :noquery t 119 | :filter (fsm-make-filter fsm) 120 | :sentinel (fsm-make-sentinel fsm)))) 121 | (buffer-disable-undo buffer) 122 | (list (plist-put state-data :proc proc) nil)) 123 | (error 124 | ;; We can't move directly to a different state in the enter state 125 | ;; function... 126 | (kill-buffer buffer) 127 | (fsm-send fsm (list :connection-failed e server service)) 128 | (list state-data nil))))) 129 | 130 | (define-state bic-connection :connecting 131 | (fsm state-data event _callback) 132 | (pcase event 133 | (`(:connection-failed ,e ,server ,service) 134 | ;; from enter-state-function 135 | (bic--fail state-data 136 | :connection-failed 137 | (format "connection to %s:%s failed: %s" 138 | server service (error-message-string e)))) 139 | (`(:sentinel ,proc ,string) 140 | (cond 141 | ((string-prefix-p "open" string) 142 | (bic--transcript fsm (format "*** %s Connected to %s\n" 143 | (format-time-string "%F %T") 144 | (plist-get state-data :server))) 145 | (cl-ecase (plist-get state-data :connection-type) 146 | ((:starttls :unencrypted) 147 | ;; Wait for STARTTLS capability etc 148 | (list :wait-for-greeting state-data nil)) 149 | (:plaintls 150 | ;; Negotiate TLS immediately 151 | (condition-case e 152 | (progn 153 | (bic--negotiate-tls state-data) 154 | ;; No error? Connection encrypted! 155 | (list :wait-for-greeting 156 | (plist-put 157 | (plist-put state-data :encrypted t) 158 | :capabilities nil))) 159 | (error 160 | (bic--fail state-data 161 | :tls-failure 162 | (format "Cannot negotiate TLS for %s: %s" 163 | (plist-get state-data :server) 164 | (error-message-string e)))))))) 165 | ((or (string-prefix-p "failed" string) 166 | (string-prefix-p "deleted" string)) 167 | ;; strip trailing newline 168 | (when (eq ?\n (aref string (1- (length string)))) 169 | (setq string (substring string 0 -1))) 170 | (let* ((contact (process-contact proc)) 171 | (server (car contact)) 172 | (service (cadr contact))) 173 | (bic--fail state-data 174 | :connection-failed 175 | (format "connection to %s:%s %s" 176 | server service string)))) 177 | (t 178 | (message "Unknown sentinel event %S" string) 179 | (list :connecting state-data nil)))) 180 | (:stop 181 | (bic--fail state-data :stopped "Stopped")) 182 | (unexpected 183 | (message "Unexpected event %S" unexpected) 184 | (list :connecting state-data nil)))) 185 | 186 | (define-state bic-connection :wait-for-greeting 187 | (fsm state-data event _callback) 188 | (pcase event 189 | (`(:filter ,process ,data) 190 | (bic--filter process data fsm) 191 | (list :wait-for-greeting state-data)) 192 | (`(:sentinel ,_process ,reason) 193 | ;; strip trailing newline 194 | (when (eq ?\n (aref reason (1- (length reason)))) 195 | (setq reason (substring reason 0 -1))) 196 | (bic--fail state-data :connection-closed reason)) 197 | (`(:line ,line) 198 | (pcase (bic--parse-greeting line) 199 | (`(:ok ,capabilities ,_greeting-text) 200 | (if (null capabilities) 201 | (list :wait-for-capabilities state-data) 202 | (plist-put state-data :capabilities capabilities) 203 | (bic--advance-connection-state fsm state-data capabilities))) 204 | (`(:bye ,text) 205 | (bic--fail state-data 206 | :server-disconnect 207 | (format "Server wants to disconnect: %s" text))))) 208 | (:stop 209 | (bic--fail state-data :stopped "Stopped")) 210 | (event 211 | (message "Got event %S" event) 212 | (list :wait-for-greeting state-data)))) 213 | 214 | (define-enter-state bic-connection :wait-for-capabilities 215 | (fsm state-data) 216 | (bic--send fsm "caps CAPABILITY\r\n") 217 | (list state-data nil)) 218 | 219 | (define-state bic-connection :wait-for-capabilities 220 | (fsm state-data event _callback) 221 | (pcase event 222 | (`(:filter ,process ,data) 223 | (bic--filter process data fsm) 224 | (list :wait-for-capabilities state-data)) 225 | (`(:sentinel ,_process ,reason) 226 | ;; strip trailing newline 227 | (when (eq ?\n (aref reason (1- (length reason)))) 228 | (setq reason (substring reason 0 -1))) 229 | (bic--fail state-data :connection-closed reason)) 230 | (`(:line ,line) 231 | (pcase (bic--parse-line line) 232 | (`("*" "CAPABILITY" . ,capability-strings) 233 | (let ((capabilities (bic--parse-capabilities capability-strings))) 234 | (list :wait-for-capabilities 235 | (plist-put state-data :capabilities capabilities)))) 236 | (`("caps" :ok . ,_) 237 | (bic--advance-connection-state 238 | fsm state-data 239 | (plist-get state-data :capabilities))) 240 | (_ 241 | (bic--fail state-data 242 | :unexpected-input 243 | (format "Unexpected: %s" line))))) 244 | (:stop 245 | (bic--fail state-data :stopped "Stopped")) 246 | (event 247 | (message "Got event %S" event) 248 | (list :wait-for-capabilities state-data)))) 249 | 250 | (define-state bic-connection :wait-for-auth-proceed 251 | (fsm state-data event _callback) 252 | (pcase event 253 | (:proceed 254 | (plist-put state-data :auth-wait nil) 255 | (bic--advance-connection-state 256 | fsm state-data 257 | (plist-get state-data :capabilities))) 258 | (`(:sentinel ,_process ,reason) 259 | ;; strip trailing newline 260 | (when (eq ?\n (aref reason (1- (length reason)))) 261 | (setq reason (substring reason 0 -1))) 262 | (bic--fail state-data :connection-closed reason)) 263 | (:stop 264 | (bic--fail state-data :stopped "Stopped")))) 265 | 266 | (defun bic--advance-connection-state (fsm state-data capabilities) 267 | "Move the connection FSM through the required states. 268 | Activate encryption if needed, authenticate. 269 | Argument STATE-DATA is the state data of FSM. 270 | Argument CAPABILITIES is the capabilities reported by the server." 271 | (cond 272 | ((and (not (plist-get state-data :encrypted)) 273 | (not (eq (plist-get state-data :connection-type) :unencrypted))) 274 | (if (member "STARTTLS" capabilities) 275 | (progn 276 | (bic--send fsm "starttls STARTTLS\r\n") 277 | (list :wait-for-starttls-response state-data)) 278 | (bic--fail state-data 279 | :starttls-not-available 280 | "STARTTLS not available!"))) 281 | ((and (not (plist-get state-data :authenticated)) 282 | (plist-get state-data :auth-wait)) 283 | ;; Our caller wants us to wait before proceeding with 284 | ;; authentication. 285 | (funcall (plist-get state-data :callback) fsm :auth-wait) 286 | (list :wait-for-auth-proceed state-data)) 287 | ((not (plist-get state-data :authenticated)) 288 | (let* ((server-mechanisms (cdr (assq :auth capabilities))) 289 | (mechanism (sasl-find-mechanism server-mechanisms))) 290 | (cond 291 | ((null mechanism) 292 | (bic--fail state-data 293 | :sasl-mechanism-not-found 294 | (format "No suitable mechanism found! We support %s, server supports %s" 295 | sasl-mechanisms server-mechanisms))) 296 | ((and (not bic-send-cleartext-password) 297 | (not (plist-get state-data :encrypted)) 298 | (member (sasl-mechanism-name mechanism) '("PLAIN" "LOGIN"))) 299 | (bic--fail state-data 300 | :sasl-cleartext-not-allowed 301 | (format "Cleartext authentication not allowed! Server offers %s" 302 | server-mechanisms))) 303 | (t 304 | (let* ((client 305 | (sasl-make-client 306 | mechanism 307 | (plist-get state-data :username) 308 | "imap" 309 | (plist-get state-data :server))) 310 | (sasl-read-passphrase (bic--read-passphrase-function state-data)) 311 | (step (catch :bic-sasl-abort (sasl-next-step client nil)))) 312 | (pcase step 313 | (:quit 314 | (bic--fail state-data 315 | :authentication-abort 316 | "User quit during IMAP authentication")) 317 | (:timeout 318 | (bic--fail state-data 319 | :authentication-abort 320 | "Timeout waiting for password during IMAP authentication")) 321 | (`(:unexpected . ,unexpected) 322 | (bic--fail state-data 323 | :authentication-abort 324 | (format "Unexpected data from auth source: %S" unexpected))) 325 | (_ 326 | ;; XXX: we can't send the AUTHENTICATE command here, because 327 | ;; sending data over a network connection means that we can 328 | ;; receive data as well, which causes a race condition 329 | ;; whereby the filter function being called with the server 330 | ;; response before we've moved on to the :sasl-auth state. 331 | ;; Thus we send the AUTHENTICATE command in the enter 332 | ;; function instead. 333 | (list :sasl-auth (plist-put 334 | (plist-put state-data :sasl-client client) 335 | :sasl-step step))))))))) 336 | (t 337 | (list :authenticated state-data)))) 338 | 339 | (define-state bic-connection :wait-for-starttls-response 340 | (fsm state-data event _callback) 341 | (pcase event 342 | (`(:filter ,process ,data) 343 | (bic--filter process data fsm) 344 | (list :wait-for-starttls-response state-data)) 345 | (`(:sentinel ,_process ,reason) 346 | ;; strip trailing newline 347 | (when (eq ?\n (aref reason (1- (length reason)))) 348 | (setq reason (substring reason 0 -1))) 349 | (bic--fail state-data :connection-closed reason)) 350 | (`(:line ,line) 351 | (pcase (bic--parse-line line) 352 | (`("starttls" :ok . ,_) 353 | (condition-case e 354 | (progn 355 | (bic--negotiate-tls state-data) 356 | ;; No error? Connection encrypted! 357 | ;; Forget capabilities and ask again on encrypted connection. 358 | (list :wait-for-capabilities 359 | (plist-put 360 | (plist-put state-data :encrypted t) 361 | :capabilities nil))) 362 | (error 363 | (bic--fail state-data 364 | :tls-failure 365 | (format "Cannot negotiate STARTTLS for %s: %s" 366 | (plist-get state-data :server) 367 | (error-message-string e)))))) 368 | (`("starttls" :bad . ,plist) 369 | (bic--fail state-data 370 | :tls-failure 371 | (format "Cannot negotiate STARTTLS: %s" 372 | (plist-get plist :text)))) 373 | (_ 374 | (bic--fail state-data 375 | :tls-failure 376 | (format "Unexpected response to STARTTTLS command: %s" line))))) 377 | (:stop 378 | (bic--fail state-data :stopped "Stopped")) 379 | (event 380 | (message "Got event %S" event) 381 | (list :wait-for-starttls-response state-data)))) 382 | 383 | (define-enter-state bic-connection :sasl-auth 384 | (fsm state-data) 385 | (let* ((client (plist-get state-data :sasl-client)) 386 | (mechanism (sasl-client-mechanism client)) 387 | (step (plist-get state-data :sasl-step))) 388 | (bic--send 389 | fsm 390 | (concat "auth AUTHENTICATE " (sasl-mechanism-name mechanism) 391 | (when (and (member "SASL-IR" (plist-get state-data :capabilities)) 392 | (sasl-step-data step)) 393 | ;; We can send an "initial response", saving a 394 | ;; roundtrip. 395 | (concat " " 396 | (propertize 397 | (base64-encode-string (sasl-step-data step) t) 398 | :sensitive t))) 399 | "\r\n"))) 400 | (list state-data nil)) 401 | 402 | (define-state bic-connection :sasl-auth 403 | (fsm state-data event _callback) 404 | (pcase event 405 | (`(:filter ,process ,data) 406 | (bic--filter process data fsm :sensitive (apply-partially #'string-prefix-p "+ ")) 407 | (list :sasl-auth state-data)) 408 | (`(:sentinel ,_process ,reason) 409 | ;; strip trailing newline 410 | (when (eq ?\n (aref reason (1- (length reason)))) 411 | (setq reason (substring reason 0 -1))) 412 | (bic--fail state-data :connection-closed reason)) 413 | (`(:line ,line) 414 | (pcase (bic--parse-line line) 415 | (`("+" ,data) 416 | (let ((client (plist-get state-data :sasl-client)) 417 | (step (plist-get state-data :sasl-step)) 418 | (sasl-read-passphrase (bic--read-passphrase-function state-data))) 419 | ;; If this is the first message from the server, and it is 420 | ;; empty, and the chosen mechanism requires the client to 421 | ;; send data first, then we shouldn't move to the next step 422 | ;; here. 423 | ;; 424 | ;; There is no way to ask the Emacs SASL library about 425 | ;; whether the client should send data first, so let's take 426 | ;; an empty message from the server as our cue. 427 | (pcase 428 | (catch :bic-sasl-abort 429 | (unless (and (zerop (length data)) 430 | (null (plist-get state-data :sasl-sent-message))) 431 | (sasl-step-set-data step (base64-decode-string data)) 432 | (setq step (sasl-next-step client step)) 433 | nil)) 434 | (`nil 435 | ;; Update state-data before sending response, to avoid a race 436 | ;; condition. plist-put only requires reassignment if the 437 | ;; list was initially empty, which we by now know is not the 438 | ;; case. 439 | (plist-put state-data :sasl-step step) 440 | (plist-put state-data :sasl-sent-message t) 441 | (bic--send fsm (concat (base64-encode-string (or (sasl-step-data step) "") t) "\r\n") 442 | :sensitive t) 443 | ;; XXX: check local success/failure, for mechanisms that 444 | ;; simultaneously authenticate the server 445 | (list :sasl-auth state-data)) 446 | (:quit 447 | (bic--fail state-data 448 | :authentication-abort 449 | "User quit during IMAP authentication")) 450 | (:timeout 451 | (bic--fail state-data 452 | :authentication-abort 453 | "Timeout waiting for password during IMAP authentication")) 454 | (other 455 | (bic--fail state-data 456 | :authentication-abort 457 | (format "Unexpected result of SASL step: %S" other)))))) 458 | (`("auth" :ok . ,plist) 459 | ;; XXX: check local success/failure here too 460 | (let ((new-capabilities 461 | (when (string= (plist-get plist :code) "CAPABILITY") 462 | (bic--parse-capabilities (split-string (plist-get plist :data)))))) 463 | (plist-put state-data :authenticated t) 464 | (plist-put state-data :capabilities new-capabilities) 465 | (plist-put state-data :sasl-client nil) 466 | (plist-put state-data :sasl-step nil) 467 | (when (plist-get state-data :password-save-function) 468 | ;; Ask the user about saving the password. 469 | (with-local-quit 470 | (funcall (plist-get state-data :password-save-function))) 471 | (plist-put state-data :password-save-function nil)) 472 | (if new-capabilities 473 | ;; The server saved us a roundtrip and sent 474 | ;; capabilities in the OK message. 475 | (list :authenticated state-data) 476 | ;; Need to ask the server for capabilities. 477 | (list :wait-for-capabilities state-data)))) 478 | (`("auth" :no . ,plist) 479 | ;; TODO: ask for better password? 480 | (bic--fail state-data 481 | :authentication-failed 482 | (format "IMAP authentication failed: %s" 483 | (plist-get plist :text)))) 484 | (`("auth" :bad . ,plist) 485 | ;; This shouldn't happen 486 | (bic--fail state-data 487 | :authentication-abort 488 | (format "Unexpected IMAP authentication error: %s" 489 | (plist-get plist :text)))) 490 | (`("*" ,_ . ,_) 491 | ;; Untagged responses can arrive at any time (2.2.2, RFC 492 | ;; 3501). Let's ignore it and hope it wasn't important. 493 | (list :sasl-auth state-data)) 494 | (_ 495 | (bic--fail state-data 496 | :unexpected-input 497 | (format "Unexpected input: %s" line))))) 498 | (:stop 499 | (bic--fail state-data :stopped "Stopped")) 500 | (event 501 | (message "Got event %S" event) 502 | (list :sasl-auth state-data)))) 503 | 504 | (defun bic--read-passphrase-function (state-data) 505 | "Return a function that returns the password. 506 | Either find the saved password using `auth-source-search', or 507 | query the user. 508 | STATE-DATA is the state data of the connection, where we get 509 | the username and server name from." 510 | (lambda (_prompt) 511 | (let ((auth-source-result 512 | (with-timeout (60 :timeout) 513 | (or 514 | (with-local-quit 515 | (auth-source-search 516 | :user (plist-get state-data :username) 517 | :host (plist-get state-data :server) 518 | :port 519 | (let ((symbolic (cl-ecase (plist-get state-data :connection-type) 520 | ((:starttls :unencrypted) 521 | "imap") 522 | (:plaintls 523 | "imaps"))) 524 | (numeric (plist-get state-data :port))) 525 | (if numeric 526 | (list symbolic numeric) 527 | symbolic)) 528 | :max 1 529 | :require '(:secret) 530 | :create t)) 531 | (and quit-flag :quit))))) 532 | (pcase auth-source-result 533 | (:timeout 534 | (throw :bic-sasl-abort :timeout)) 535 | (:quit 536 | (throw :bic-sasl-abort :quit)) 537 | ((and `(,found . ,_) (guard found)) 538 | ;; Some non-default auth-source backends might return an 539 | ;; empty list, despite us passing :create t. The `guard' 540 | ;; above makes us reach the "unexpected" case below in that 541 | ;; case. 542 | (let ((secret (plist-get found :secret)) 543 | (save-function (plist-get found :save-function))) 544 | (plist-put state-data :password-save-function save-function) 545 | ;; According to the `auth-source-search' documentation, the 546 | ;; return value for :secret might be a function, which 547 | ;; should be called to return the value. However, it turns 548 | ;; out that sometimes that function returns another 549 | ;; function. 550 | (when (functionp secret) 551 | (setq secret (funcall secret))) 552 | (when (functionp secret) 553 | (setq secret (funcall secret))) 554 | (cl-assert (stringp secret) t) 555 | ;; Copy the password, as sasl.el wants to erase it. 556 | (copy-sequence secret))) 557 | (other 558 | (throw :bic-sasl-abort (cons :unexpected other))))))) 559 | 560 | (define-enter-state bic-connection :authenticated 561 | (fsm state-data) 562 | (funcall (plist-get state-data :callback) fsm :authenticated) 563 | (list state-data nil)) 564 | 565 | (define-state bic-connection :authenticated 566 | (fsm state-data event callback) 567 | (pcase event 568 | (`(:cmd ,cmd ,early-callbacks) 569 | (let* ((tag-number (or (plist-get state-data :next-tag) 0)) 570 | (next-tag (1+ tag-number)) 571 | (tag-string (number-to-string tag-number)) 572 | (pending-commands 573 | ;; Need to keep commands in the correct order. We 574 | ;; shouldn't have that many pending commands, so 575 | ;; appending all the time should be fine. 576 | (append (plist-get state-data :pending-commands) 577 | (list (list tag-string early-callbacks callback))))) 578 | (plist-put state-data :pending-commands pending-commands) 579 | (plist-put state-data :next-tag next-tag) 580 | (bic--send fsm (concat tag-string " " cmd "\r\n")) 581 | (list :authenticated state-data))) 582 | 583 | (`(:filter ,process ,data) 584 | (bic--filter process data fsm) 585 | (list :authenticated state-data)) 586 | 587 | (`(:line ,line) 588 | (bic--handle-line line state-data) 589 | (list :authenticated state-data)) 590 | 591 | (`(:sentinel ,_process ,reason) 592 | ;; strip trailing newline 593 | (when (eq ?\n (aref reason (1- (length reason)))) 594 | (setq reason (substring reason 0 -1))) 595 | (bic--fail state-data :connection-closed reason)) 596 | 597 | (:stop 598 | (bic--fail state-data :stopped "Stopped")))) 599 | 600 | (defun bic--handle-line (line state-data) 601 | "Handle a single LINE received from the server. 602 | STATE-DATA is the connection state data, used to find callback 603 | functions for incoming responses." 604 | (pcase (bic--parse-line line) 605 | (`("*" . ,rest) 606 | (unless 607 | ;; maybe send results early 608 | (catch 'handled 609 | (dolist (early-callback 610 | (cl-second (car (plist-get state-data :pending-commands)))) 611 | (when (equal (nth (cl-first early-callback) rest) 612 | (cl-second early-callback)) 613 | ;; If `:keep' is specified instead of a function, 614 | ;; always keep the line for the final response. 615 | (if (eq (cl-third early-callback) :keep) 616 | (plist-put state-data :response-acc 617 | (cons rest (plist-get state-data :response-acc))) 618 | ;; Otherwise, pass matching lines to the callback 619 | ;; function. 620 | (funcall (cl-third early-callback) rest)) 621 | (throw 'handled t)))) 622 | ;; If there's a callback function for unmatched untagged 623 | ;; response lines, call it... 624 | (let ((untagged-callback (plist-get state-data :untagged-callback))) 625 | (if untagged-callback 626 | (funcall untagged-callback rest) 627 | ;; ...otherwise just store the line in the state. 628 | (plist-put state-data :response-acc 629 | (cons rest (plist-get state-data :response-acc))))))) 630 | (`("+" . ,_rest) 631 | ;; Continuation response. XXX: do something sensible 632 | ) 633 | (`(,tag ,type . ,rest) 634 | (let* ((pending-commands (plist-get state-data :pending-commands)) 635 | (entry (assoc tag pending-commands)) 636 | (command-callback (cl-third entry)) 637 | (new-pending-commands (delq entry pending-commands)) 638 | (response-acc (plist-get state-data :response-acc))) 639 | (plist-put state-data :response-acc nil) 640 | (plist-put state-data :pending-commands new-pending-commands) 641 | (if command-callback 642 | (funcall command-callback (list type rest response-acc)) 643 | (warn "Unknown tag `%s' when processing line `%s'" 644 | tag line)))) 645 | (_ 646 | (fsm-debug-output "Unexpected line: '%s'" line)))) 647 | 648 | (defun bic-command (fsm command callback &optional early-callbacks) 649 | "Send an IMAP command through the connection referred to by FSM. 650 | COMMAND is a string containing an IMAP command minus the tag. 651 | 652 | CALLBACK is a function that takes one argument of the form 653 | \(RESPONSE TEXT RESPONSE-LINES), where RESPONSE is a string 654 | containing the response type, typically \"OK\", \"NO\" or 655 | \"BAD\", TEXT is the rest of the tagged response line, and 656 | RESPONSE-LINES is a list of (TYPE TEXT) entries, one for each 657 | untagged response line. If an UNTAGGED-CALLBACK was provided 658 | when the FSM was started, RESPONSE-LINES will be empty unless 659 | explicitly populated using EARLY-CALLBACKS. 660 | 661 | The callback function will be called when the command has 662 | finished. There is no immediate response. 663 | 664 | EARLY-CALLBACKS is a list with elements of the form: 665 | 666 | (N RESPONSE-NAME FUNCTION) 667 | 668 | where N is an integer and RESPONSE-NAME is a string. 669 | If the Nth word of a response line for this command is `equal' 670 | to RESPONSE-NAME, then FUNCTION is called with the response 671 | line as the only argument, and the response line in question is 672 | not included in the final response. N starts at 0, and does not 673 | include the leading \"*\" tag. Alternatively, the keyword `:keep' may 674 | be given for FUNCTION, in which case the matching line will be 675 | included in RESPONSE-LINES." 676 | (fsm-send fsm `(:cmd ,command ,early-callbacks) callback)) 677 | 678 | (defun bic-uids-command (fsm prefix uid-ranges suffix callback &optional early-callbacks) 679 | "Send one or more IMAP commands, respecting length limits. 680 | The commands are sent through the connection referred to by FSM. 681 | The logical command to send is PREFIX, plus the uids in 682 | UID-RANGES, plus SUFFIX. If the command would be longer than 683 | 8192 octets (the limit recommended in RFC 7162), it is split into 684 | several commands, each dealing with part of the uid ranges. 685 | 686 | After all commands have been completed, CALLBACK is called with 687 | two arguments. The first argument is the 'worst' response type 688 | received, i.e. `:ok' if all responses were \"OK\", `:no' if some 689 | were \"NO\" but none were \"BAD\", and `:bad' if at least one was 690 | \"BAD\". The second argument is a list whose elements are of the 691 | form (RESPONSE TEXT RESPONSE-LINES). See `bic-command' for the 692 | meaning of those values. 693 | 694 | For EARLY-CALLBACKS, see `bic-command'." 695 | (let* ((ranges (bic-format-ranges-limit 696 | uid-ranges 697 | (- 8192 (length prefix) (length suffix)))) 698 | (remaining (length ranges)) 699 | responses 700 | (worst-response :ok) 701 | (one-callback 702 | (lambda (response) 703 | (cl-ecase (car response) 704 | (:ok t) 705 | (:no 706 | (when (eq worst-response :ok) 707 | (setq worst-response :no))) 708 | (:bad 709 | (setq worst-response :bad))) 710 | (push response responses) 711 | (cl-decf remaining) 712 | (when (zerop remaining) 713 | (funcall callback worst-response (nreverse responses)))))) 714 | (or ranges (error "No UID ranges to send")) 715 | (dolist (range ranges) 716 | (fsm-send fsm (list :cmd (concat prefix range suffix) early-callbacks) 717 | one-callback)))) 718 | 719 | (defun bic--fail (state-data keyword reason) 720 | "Go to the \"failure state\". 721 | The return value from this function can be returned from a 722 | `define-state' function. 723 | 724 | STATE-DATA is the state data of the bic-connection state machine. 725 | KEYWORD is a keyword indicating the failure condition. 726 | REASON is a string giving more information." 727 | (plist-put state-data :fail-keyword keyword) 728 | (plist-put state-data :fail-reason reason) 729 | (list nil state-data)) 730 | 731 | (define-enter-state bic-connection nil 732 | (fsm state-data) 733 | ;; Delete the connection just to be sure it's gone. 734 | (let ((proc (plist-get state-data :proc))) 735 | (when (processp proc) 736 | (let ((buffer (process-buffer proc))) 737 | (delete-process proc) 738 | (when (buffer-live-p buffer) 739 | (kill-buffer buffer))))) 740 | (let ((callback (plist-get state-data :callback)) 741 | (fail-keyword (or (plist-get state-data :fail-keyword) 742 | :unknown-reason)) 743 | (fail-reason (or (plist-get state-data :fail-reason) 744 | "Unexpected error"))) 745 | (bic--transcript fsm (format "*** %s Connection closed: %s\n" 746 | (format-time-string "%F %T") 747 | fail-reason)) 748 | (funcall callback fsm (list :disconnected fail-keyword fail-reason))) 749 | (list nil nil)) 750 | 751 | (define-state bic-connection nil 752 | (_fsm state-data _event _callback) 753 | ;; Ignore all events 754 | (list nil state-data)) 755 | 756 | (defun bic--negotiate-tls (state-data) 757 | "Negotiate a TLS connection. 758 | Use the connection and host name from STATE-DATA." 759 | (gnutls-negotiate :process (plist-get state-data :proc) 760 | :hostname (plist-get state-data :server) 761 | :verify-error (if bic-ignore-tls-errors 762 | (list :nothing) 763 | t))) 764 | 765 | (defvar-local bic--unread-start-marker nil) 766 | 767 | (defvar-local bic--literal-start-marker nil) 768 | 769 | (defvar-local bic--literal-expected-length nil) 770 | 771 | (defvar-local bic--line-acc nil) 772 | 773 | (cl-defun bic--filter (process data fsm &key sensitive) 774 | (process-put process :latest-received (current-time)) 775 | (with-current-buffer (process-buffer process) 776 | (unless bic--unread-start-marker 777 | (setq bic--unread-start-marker (point-min-marker))) 778 | 779 | (goto-char (point-max)) 780 | (insert data) 781 | 782 | (stop-process process) 783 | ;; Handle input as long as there is something left to handle. 784 | ;; bic--read-input should return t in this case, and move either 785 | ;; bic--unread-start-marker or bic--literal-start-marker. 786 | ;; Double-check that we don't get stuck in an infinite loop. 787 | (unwind-protect 788 | (cl-flet 789 | ((current-progress 790 | () 791 | (list (and bic--unread-start-marker 792 | (marker-position bic--unread-start-marker)) 793 | (and bic--literal-start-marker 794 | (marker-position bic--literal-start-marker))))) 795 | (let ((previous (current-progress))) 796 | (while (bic--read-input fsm sensitive) 797 | (when (equal previous (current-progress)) 798 | (error "No progress")) 799 | (setq previous (current-progress))))) 800 | (continue-process process)))) 801 | 802 | (defun bic--read-input (fsm sensitive) 803 | "Read what the server sent, and send as :line messages to FSM. 804 | Keep calling this function until it returns nil. 805 | Argument SENSITIVE means that this line of input should be displayed as in the transcript buffer." 806 | (cond 807 | ((null bic--literal-start-marker) 808 | ;; Find complete lines, terminated by CRLF 809 | (goto-char bic--unread-start-marker) 810 | (when (search-forward "\r\n" nil t) 811 | (let* ((line-end (match-end 0)) 812 | (received-line (buffer-substring 813 | bic--unread-start-marker 814 | (match-beginning 0)))) 815 | (bic--transcript 816 | fsm 817 | (concat "S: " 818 | (if (and sensitive (funcall sensitive received-line)) 819 | "" 820 | (if bic-redact-transcript 821 | (bic--maybe-redact-received received-line bic--line-acc) 822 | received-line)) 823 | "\n")) 824 | ;; Does a literal start on this line? 825 | (if (string-match "{\\([0-9]+\\)}$" received-line) 826 | (progn 827 | (push (substring received-line 0 (match-beginning 0)) 828 | bic--line-acc) 829 | (setq bic--literal-start-marker (copy-marker line-end)) 830 | (setq bic--literal-expected-length 831 | (string-to-number (match-string 1 received-line))) 832 | t) 833 | ;; Send the line as an event to the FSM 834 | (let ((line (nreverse (cons received-line bic--line-acc)))) 835 | (setq bic--line-acc nil) 836 | (set-marker bic--unread-start-marker line-end) 837 | (fsm-send fsm (list :line line)) 838 | t))))) 839 | ((and bic--literal-start-marker 840 | (>= (- (point-max) bic--literal-start-marker) 841 | bic--literal-expected-length)) 842 | ;; The literal is complete. Save the markers in our list, and 843 | ;; keep parsing. 844 | (bic--transcript fsm (format "S: <%d bytes omitted>\n" bic--literal-expected-length)) 845 | (let ((literal-end (+ bic--literal-start-marker bic--literal-expected-length))) 846 | (push (cons (bic--issue-marker bic--literal-start-marker) 847 | (bic--issue-marker literal-end)) 848 | bic--line-acc) 849 | (setq bic--literal-start-marker nil) 850 | (set-marker bic--unread-start-marker literal-end) 851 | ;; TODO: is this too often? 852 | (bic--prune-old-literals) 853 | t)))) 854 | 855 | (defun bic--issue-marker (value) 856 | "Create a marker pointing at VALUE, and record it. 857 | VALUE must be greater than any marker previously issued." 858 | (unless bic--issued-markers 859 | (setq bic--issued-markers (make-hash-table :weakness 'value))) 860 | (let ((marker (copy-marker value))) 861 | (prog1 862 | marker 863 | (puthash bic--next-issued-marker marker bic--issued-markers) 864 | (cl-incf bic--next-issued-marker)))) 865 | 866 | (defun bic--prune-old-literals () 867 | "Remove data before the first marker we know about." 868 | ;; We send chunks of data to the client in the form of marker pairs, 869 | ;; but we'd like to know when the client is done with the data, so 870 | ;; that we can delete the data from the connection buffer and 871 | ;; prevent it from growing indefinitely. We accomplish this by 872 | ;; keeping the markers in a weak hash table, such that the entries 873 | ;; are removed when the markers are garbage collected. 874 | ;; Alternatively, the client can explicitly make the markers point 875 | ;; nowhere, which we explicitly check for. 876 | ;; 877 | ;; Since a hash table is not an ordered list, we keep two "indexes": 878 | ;; one for the next key to use when inserting, and one for the next 879 | ;; pruning candidate. 880 | (while (and 881 | ;; In principle, we should check for integer 882 | ;; overflow/wraparound, but even on a 32-bit Emacs this 883 | ;; should let you download 134 million messages on a single 884 | ;; connection before you run into trouble... 885 | (< bic--next-collected-marker bic--next-issued-marker) 886 | (let ((maybe-marker (gethash bic--next-collected-marker bic--issued-markers))) 887 | ;; If the marker has been garbage collected, it won't be 888 | ;; in our weak hash table anymore: 889 | (or (null maybe-marker) 890 | ;; If it has been explicitly cleared, remove it from 891 | ;; the table. 892 | (when (null (marker-position maybe-marker)) 893 | (remhash bic--next-collected-marker bic--issued-markers) 894 | t)))) 895 | (cl-incf bic--next-collected-marker)) 896 | (let ((delete-until 897 | (or (gethash bic--next-collected-marker bic--issued-markers) 898 | bic--unread-start-marker))) 899 | (delete-region (point-min) delete-until))) 900 | 901 | (cl-defun bic--send (fsm string &key sensitive) 902 | (bic--transcript 903 | fsm 904 | (concat "C: " 905 | (if sensitive 906 | "" 907 | (let* ((trimmed 908 | (if (string= (substring string -2) "\r\n") 909 | (substring string 0 -2) 910 | string)) 911 | ;; TODO: we assume that the string starts 912 | ;; "non-sensitive", and switches to "sensitive" 913 | ;; throughout. 914 | (sensitive-from (next-single-property-change 0 :sensitive trimmed))) 915 | (if sensitive-from 916 | (concat (substring trimmed 0 sensitive-from) "") 917 | trimmed))) 918 | "\n")) 919 | 920 | (send-string (plist-get (fsm-get-state-data fsm) :proc) string)) 921 | 922 | (defun bic--string-equals-at (needle haystack position) 923 | "Return non-nil if NEEDLE can be found in HAYSTACK at POSITION." 924 | (let ((needle-length (length needle))) 925 | (and (<= (+ position needle-length) (length haystack)) 926 | (let (mismatch (i 0)) 927 | (while (and (not mismatch) (< i needle-length)) 928 | (if (eq (elt needle i) (elt haystack (+ position i))) 929 | (cl-incf i) 930 | (setq mismatch t))) 931 | (not mismatch))))) 932 | 933 | (defun bic--maybe-redact-received (received-line line-acc) 934 | "Hide personal data such as addresses, subjects in transcript. 935 | RECEIVED-LINE is the line to be redacted. 936 | The return value is a string where personal data has been replaced 937 | with \"\", with a display property so that the actual 938 | text is still visible in the transcript buffer, but doesn't get 939 | copied along when the transcript is copied to somewhere else. 940 | 941 | LINE-ACC is a list of previously received lines for the current 942 | command, used to establish context for parsing the current line." 943 | (let ((line-so-far (reverse (cons received-line line-acc))) 944 | redact-at) 945 | (cond 946 | ((and (stringp (car line-so-far)) 947 | (string-match "^\\* [^ ]+ FETCH (" (car line-so-far))) 948 | ;; Now, dig down to ENVELOPE. 949 | (cl-loop 950 | with i = (match-end 0) 951 | with parenthesis-depth = 0 952 | with envelope-parts = nil 953 | while line-so-far 954 | if (consp (car line-so-far)) 955 | ;; A pair of markers. Not what we're looking for. 956 | do (pop line-so-far) 957 | else if (>= i (length (car line-so-far))) 958 | do (pop line-so-far) 959 | (setq i 0) 960 | else do 961 | (pcase (elt (car line-so-far) i) 962 | (?\( 963 | ;; Opening parenthesis. If we're inside the envelope, enter it. 964 | (if envelope-parts 965 | (progn 966 | (cl-incf i) 967 | (cl-incf parenthesis-depth)) 968 | ;; Otherwise, try to skip over it. 969 | (condition-case _e 970 | (setq i (nth 2 (bic--parse-line 971 | (list (car line-so-far)) 972 | :line-start nil 973 | :start-at (1+ i) 974 | :closing-parenthesis ?\)))) 975 | (error 976 | ;; (Presumably) the closing parenthesis is in the next 977 | ;; segment. 978 | (pop line-so-far) 979 | (setq i 0) 980 | (cl-incf parenthesis-depth))))) 981 | (?\) 982 | ;; Closing parenthesis. 983 | (cl-incf i) 984 | (setq parenthesis-depth (max 0 (1- parenthesis-depth))) 985 | (when (and (eq parenthesis-depth 1) (eq (car envelope-parts) 'address)) 986 | ;; When dropping back to depth 1, we have finished one address. 987 | (pop envelope-parts))) 988 | (?\" 989 | ;; String. 990 | ;; There is no reason for this not to be terminated, but 991 | ;; let's not crash over that... 992 | (let ((start i)) 993 | (condition-case _e 994 | (setq i (nth 1 (bic--parse-quoted-string (car line-so-far) i))) 995 | (error 996 | ;; Just drop the segment in that case. 997 | (pop line-so-far) 998 | (setq i 0))) 999 | (unless (zerop i) 1000 | ;; Now check if this is something we want to hide. 1001 | (let ((envelope-part (car envelope-parts))) 1002 | (when (and envelope-part (eq (car line-so-far) received-line)) 1003 | (push (cons (1+ start) (1- i)) redact-at)) 1004 | ;; If this string is part of an address, don't drop 1005 | ;; from envelope-parts yet. 1006 | (unless (eq envelope-part 'address) 1007 | (pop envelope-parts)))))) 1008 | (?\s 1009 | ;; Space. Just move forward. 1010 | (cl-incf i)) 1011 | (_ 1012 | ;; Looks like an atom. Is it ENVELOPE, perhaps? 1013 | (cond 1014 | ((bic--string-equals-at "ENVELOPE (" (car line-so-far) i) 1015 | (setq envelope-parts '(nil text 1016 | address address address 1017 | address address address 1018 | message-id message-id))) 1019 | ;; Or is it NIL inside an envelope? If so, it's one thing 1020 | ;; we don't have to redact. 1021 | ((and (eq parenthesis-depth 1) 1022 | (bic--string-equals-at "NIL" (car line-so-far) i)) 1023 | (pop envelope-parts))) 1024 | ;; Skip over the atom 1025 | (pcase (cl-position ?\s (car line-so-far) :start i) 1026 | (`nil 1027 | (pop line-so-far) 1028 | (setq i 0)) 1029 | (new-i 1030 | (setq i new-i)))))) 1031 | (if (null redact-at) 1032 | received-line 1033 | (with-temp-buffer 1034 | (insert received-line) 1035 | (goto-char (point-min)) 1036 | (dolist (from-to redact-at) 1037 | ;; String offsets are 0-based, but buffer offsets are 1-based. 1038 | (let* ((from (1+ (car from-to))) 1039 | (to (1+ (cdr from-to))) 1040 | (text (buffer-substring from to))) 1041 | (setf (buffer-substring from to) 1042 | (propertize "redacted" 1043 | 'face 'shadow 1044 | 'display text 1045 | 'yank-handler '(nil ""))))) 1046 | (buffer-string)))) 1047 | (t 1048 | received-line)))) 1049 | 1050 | ;; Defined in view.el 1051 | (defvar view-no-disable-on-exit) 1052 | 1053 | (defun bic--transcript (fsm string) 1054 | "Add a line to the transcript buffer for FSM. 1055 | STRING is the line to add. It should start with \"S: \", \"C: \" 1056 | or \"*** \", and end with a newline." 1057 | (with-current-buffer (get-buffer-create (format bic-transcript-buffer (plist-get (fsm-get-state-data fsm) :name))) 1058 | (unless (derived-mode-p 'view-mode) 1059 | (view-mode) 1060 | (setq-local view-no-disable-on-exit t)) 1061 | (save-excursion 1062 | (goto-char (point-max)) 1063 | (let ((inhibit-read-only t)) 1064 | (insert string))))) 1065 | 1066 | (defun bic--parse-greeting (line) 1067 | "Parse the greeting from the server. 1068 | LINE is what the server sent after the connection was established, 1069 | usually starting with \"* OK\" or \"* BYE\". 1070 | 1071 | Return a list of three elements: 1072 | 1073 | - one of the keywords :ok and :bye 1074 | 1075 | - a list of IMAP capabilities sent by the server. If the server 1076 | didn't include capabilities in its greeting, this is an empty list. 1077 | 1078 | - the text in the greeting 1079 | 1080 | If the greeting doesn't match what we expect, signal an error." 1081 | (pcase (bic--parse-line line) 1082 | (`("*" ,(and (or :ok :bye) type) . ,plist) 1083 | (if (string= "CAPABILITY" (plist-get plist :code)) 1084 | (list type (bic--parse-capabilities 1085 | (split-string (plist-get plist :data))) 1086 | (plist-get plist :text)) 1087 | (list type nil (plist-get plist :text)))) 1088 | ;; TODO: PREAUTH 1089 | (_ 1090 | (error "Unexpected greeting: %s" line)))) 1091 | 1092 | 1093 | (defun bic--parse-capabilities (strings) 1094 | "Parse server capabilities. 1095 | STRINGS is a list of strings, naming the capabilities advertised 1096 | by the server. 1097 | 1098 | The capabilities are returned unchanged, except for those 1099 | starting with \"AUTH=\". The supported authentication methods 1100 | are returned in a separate list element, whose car is the 1101 | keyword :auth, and whose cdr is the list of authentication 1102 | capabilities with the leading \"AUTH=\" stripped away." 1103 | (let (capabilities auth) 1104 | (dolist (capability strings) 1105 | (if (string-prefix-p "AUTH=" capability) 1106 | (push (substring capability 5) auth) 1107 | (push capability capabilities))) 1108 | (cons (cons :auth auth) capabilities))) 1109 | 1110 | (cl-defun bic--parse-line (line 1111 | &key (line-start t) ((:start-at i) 0) closing-parenthesis 1112 | &aux tokens) 1113 | (when line-start 1114 | (cond 1115 | ((not (stringp (car line))) 1116 | ;; No empty lines, or lines starting with a literal 1117 | (cl-return-from bic--parse-line :unexpected)) 1118 | ((string-prefix-p "+" (car line)) 1119 | ;; Continuation line 1120 | (cl-return-from bic--parse-line 1121 | (cl-list* "+" 1122 | (if (< (length (car line)) 2) 1123 | ;; In principle, this should always be followed by a space. 1124 | ;; In practice, Exchange sends just a plus sign on a line. 1125 | "" 1126 | (substring (car line) 2)) 1127 | (cdr line)))) 1128 | ;; If the line starts with a tag and one of the words OK, NO, BAD, 1129 | ;; BYE or PREAUTH, then the rest of the line should be parsed as 1130 | ;; resp-text. 1131 | ;; XXX: tag is `any ASTRING-CHAR expect "+"' 1132 | ((string-match 1133 | "^\\([^ +]+\\) \\(OK\\|NO\\|BAD\\|BYE\\|PREAUTH\\) \\(.*\\)$" 1134 | (car line)) 1135 | (cl-return-from bic--parse-line 1136 | (if (cdr line) 1137 | ;; Can't have literal on lines with resp-text 1138 | :unexpected 1139 | (let ((tag (match-string 1 (car line))) 1140 | (type (match-string 2 (car line))) 1141 | (rest (match-string 3 (car line)))) 1142 | (cl-list* tag (intern (concat ":" (downcase type))) 1143 | (bic--parse-resp-text rest)))))))) 1144 | 1145 | (while line 1146 | (cond 1147 | ((consp (car line)) 1148 | ;; A literal, represented as a pair of markers. 1149 | (push (pop line) tokens)) 1150 | ((or (null i) (>= i (length (car line)))) 1151 | (pop line) 1152 | (setq i 0)) 1153 | (t 1154 | (cl-case (aref (car line) i) 1155 | (?\" 1156 | (cl-destructuring-bind (string new-i) 1157 | (bic--parse-quoted-string (car line) i) 1158 | (push string tokens) 1159 | (setq i new-i))) 1160 | ((?\) ?\]) 1161 | (if (not (eq (aref (car line) i) closing-parenthesis)) 1162 | (error "Unexpected closing parenthesis in %S" line) 1163 | (cl-return-from bic--parse-line (list (nreverse tokens) line (1+ i))))) 1164 | ((?\( ?\[) 1165 | (let ((closing 1166 | (cl-ecase (aref (car line) i) 1167 | (?\( ?\)) 1168 | (?\[ ?\])))) 1169 | 1170 | (cl-destructuring-bind (subtokens new-line new-i) 1171 | (bic--parse-line 1172 | line :line-start nil :start-at (1+ i) :closing-parenthesis closing) 1173 | (push subtokens tokens) 1174 | (setq line new-line 1175 | i new-i)))) 1176 | (?\s 1177 | ;; We're being liberal here, accepting superfluous spaces. 1178 | (cl-incf i)) 1179 | (t 1180 | ;; TODO: can we get away with representing anything else as a 1181 | ;; string? 1182 | (let* ((new-i (cl-position-if 1183 | ;; TODO: what about "("? 1184 | (lambda (c) (memq c '(?\s ?\) ?\[ ?\]))) 1185 | (car line) :start i)) 1186 | ;; new-i may be nil 1187 | (token (substring (car line) i new-i))) 1188 | (push token tokens) 1189 | (setq i new-i))))))) 1190 | 1191 | (if closing-parenthesis 1192 | (error "Expected closing `%c'" closing-parenthesis) 1193 | (nreverse tokens))) 1194 | 1195 | (defun bic--parse-resp-text (resp-text) 1196 | "Parse RESP-TEXT, and return a proplist. 1197 | The proplist always contains the key :text, for the text part of 1198 | RESP-TEXT. If there is a resp-text-code, return it under the key 1199 | :code, and return its extra data item, if any, under :data." 1200 | ;;; resp-text = ["[" resp-text-code "]" SP] text 1201 | ;;; 1202 | ;;; resp-text-code = "ALERT" / 1203 | ;;; "BADCHARSET" [SP "(" astring *(SP astring) ")" ] / 1204 | ;;; capability-data / "PARSE" / 1205 | ;;; "PERMANENTFLAGS" SP "(" 1206 | ;;; [flag-perm *(SP flag-perm)] ")" / 1207 | ;;; "READ-ONLY" / "READ-WRITE" / "TRYCREATE" / 1208 | ;;; "UIDNEXT" SP nz-number / "UIDVALIDITY" SP nz-number / 1209 | ;;; "UNSEEN" SP nz-number / 1210 | ;;; atom [SP 1*] 1211 | ;; TODO: find right amount of greediness. Currently, we assume that 1212 | ;; 'text' does not contain a right square bracket. 1213 | (if (string-match "\\[\\([^]\s]+\\)\\(?: \\([^]]*\\)\\)?\\]\\(?: \\(.*\\)\\)?" resp-text) 1214 | (let ((resp-text-code (match-string 1 resp-text)) 1215 | (resp-text-data (match-string 2 resp-text)) 1216 | (text (match-string 3 resp-text))) 1217 | (list :code resp-text-code 1218 | :data resp-text-data 1219 | :text text)) 1220 | (list :text resp-text))) 1221 | 1222 | (defun bic--parse-quoted-string (line start) 1223 | "Parse a quoted string in LINE, starting at START. 1224 | Return a list with two elements: the parsed string, and 1225 | the position beyond the closing double quote." 1226 | ;;; quoted = DQUOTE *QUOTED-CHAR DQUOTE 1227 | ;;; 1228 | ;;; QUOTED-CHAR = / 1229 | ;;; "\" quoted-specials 1230 | ;;; 1231 | ;;; quoted-specials = DQUOTE / "\" 1232 | ;; Move past opening double quote. 1233 | (cl-incf start) 1234 | (let ((i start) 1235 | string-parts) 1236 | (while (and (< i (length line)) 1237 | (setq i 1238 | (cl-position-if 1239 | (lambda (c) (memq c '(?\" ?\\))) 1240 | line :start i)) 1241 | (not (eq (aref line i) ?\"))) 1242 | ;; We found a backslash. It escapes the following character. 1243 | (push (substring line start i) string-parts) 1244 | (cl-incf i) 1245 | (push (string (aref line i)) string-parts) 1246 | (cl-incf i) 1247 | (setf start i)) 1248 | (unless i 1249 | (error "IMAP string not terminated")) 1250 | (push (substring line start i) string-parts) 1251 | (list (apply #'concat (nreverse string-parts)) 1252 | (1+ i)))) 1253 | 1254 | (defun bic-quote-string (string) 1255 | "Return STRING as an IMAP quoted string. 1256 | The return value includes the surrounding double quotes." 1257 | (let ((acc (list "\"")) 1258 | (i 0)) 1259 | (while (and i (< i (length string))) 1260 | (let* ((to-escape (cl-position-if 1261 | (lambda (c) (memq c '(?\" ?\\ ?\r ?\n))) 1262 | string :start i)) 1263 | (char (when to-escape (aref string to-escape)))) 1264 | (when (memq char '(?\r ?\n)) 1265 | ;; You should have sent a literal instead. 1266 | (error "Cannot send CRLF as quoted string")) 1267 | (push (substring string i to-escape) acc) 1268 | (if (null char) 1269 | (setq i nil) 1270 | (push (string ?\\ char) acc) 1271 | (setq i (1+ to-escape))))) 1272 | (push "\"" acc) 1273 | (apply #'concat (nreverse acc)))) 1274 | 1275 | (defun bic-expand-literals (sexp) 1276 | "Replace marker pairs with strings in output from `bic--parse-line'. 1277 | Markers are set to point nowhere afterwards. Modifies SEXP 1278 | destructively, and returns it." 1279 | (pcase sexp 1280 | (`(,(and start-marker (pred markerp)) 1281 | . ,(and end-marker (pred markerp))) 1282 | (unless (and (marker-position start-marker) 1283 | (marker-position end-marker)) 1284 | (error "Marker already cleared")) 1285 | (with-current-buffer (marker-buffer start-marker) 1286 | (prog1 1287 | (buffer-substring start-marker end-marker) 1288 | (set-marker start-marker nil) 1289 | (set-marker end-marker nil)))) 1290 | ((pred listp) 1291 | (mapcar 'bic-expand-literals sexp)) 1292 | ((pred markerp) 1293 | ;; This should have been caught in the first case. 1294 | (error "Unexpected marker")) 1295 | ((pred atom) 1296 | sexp) 1297 | (_ 1298 | (error "Cannot expand literals in %S" sexp)))) 1299 | 1300 | (defun bic-number-to-string (number) 1301 | "Like `number-to-string', but always treats NUMBER as an integer. 1302 | If NUMBER is a float, it is truncated to the integer closest to 0. 1303 | This works correctly even if NUMBER is outside Emacs' integer range." 1304 | (if (integerp number) 1305 | (number-to-string number) 1306 | (let ((float-string (number-to-string number))) 1307 | (substring float-string 0 (cl-position ?. float-string))))) 1308 | 1309 | (defun bic-format-ranges (ranges) 1310 | "Format RANGES as a sequence-set. 1311 | RANGES is either a single cons, (START . END), or a list 1312 | where each element is either a number or a (START . END) cons. 1313 | This is the type of value returned by `gnus-compress-sequence'. 1314 | 1315 | All numbers may be either integers or floats. They will be 1316 | formatted as integers." 1317 | (pcase ranges 1318 | (`(,(and (pred numberp) start) . ,(and (pred numberp) end)) 1319 | (concat (bic-number-to-string start) ":" (bic-number-to-string end))) 1320 | (_ 1321 | (let (parts) 1322 | (dolist (range-or-number ranges) 1323 | (pcase range-or-number 1324 | (`(,(and (pred numberp) start) . ,(and (pred numberp) end)) 1325 | (push (concat (bic-number-to-string start) ":" (bic-number-to-string end)) parts)) 1326 | ((pred numberp) 1327 | (push (bic-number-to-string range-or-number) parts)) 1328 | (_ 1329 | (error "Invalid number or range: %S" range-or-number)))) 1330 | (mapconcat 'identity (nreverse parts) ","))))) 1331 | 1332 | (defun bic-format-ranges-limit (ranges limit) 1333 | "Format RANGES into a set of IMAP ranges, each respecting LIMIT. 1334 | Return a list of strings." 1335 | (let* ((all-ranges-string (bic-format-ranges ranges)) 1336 | (start 0) 1337 | our-ranges) 1338 | (while (> (- (length all-ranges-string) start) limit) 1339 | (let ((break-at-comma 1340 | (cl-position ?, all-ranges-string 1341 | :start start :end (+ start limit 1) :from-end t))) 1342 | (or break-at-comma (error "Cannot break ranges into smaller ranges")) 1343 | (push (substring all-ranges-string start break-at-comma) our-ranges) 1344 | (setq start (1+ break-at-comma)))) 1345 | (push (substring all-ranges-string start) our-ranges) 1346 | (nreverse our-ranges))) 1347 | 1348 | (defun bic-parse-sequence-set (sequence-set-string) 1349 | "Parse a sequence set into ranges. 1350 | SEQUENCE-SET-STRING is a string matching `sequence-set' in RFC 1351 | 3509. 1352 | 1353 | Does not handle sequence sets including \"*\"." 1354 | (let ((start 0) (i 0) 1355 | (ranges nil)) 1356 | (cl-flet 1357 | ((to-range 1358 | (seq-number-or-range) 1359 | (cond 1360 | ((string-match "^[0-9]+$" seq-number-or-range) 1361 | (let ((n (string-to-number seq-number-or-range))) 1362 | (cons n n))) 1363 | ((string-match "^\\([0-9]+\\):\\([0-9]+\\)$" seq-number-or-range) 1364 | (let ((first-number (string-to-number (match-string 1 seq-number-or-range))) 1365 | (second-number (string-to-number (match-string 2 seq-number-or-range)))) 1366 | ;; The range endpoints can come in any order. 1367 | (cons (min first-number second-number) 1368 | (max first-number second-number)))) 1369 | (t 1370 | (error "Invalid seq-number-or-range: %S" seq-number-or-range))))) 1371 | (while (and (< i (length sequence-set-string)) 1372 | (setq i (cl-position ?, sequence-set-string :start i))) 1373 | ;; We found a comma. 1374 | (setq ranges (push (to-range (substring sequence-set-string start i)) ranges)) 1375 | (cl-incf i) 1376 | (setf start i)) 1377 | (setq ranges (push (to-range (substring sequence-set-string start)) ranges))) 1378 | ;; Everything parsed. However, the server is allowed to return 1379 | ;; the ranges in any order, and with overlaps. Let's 1380 | ;; canonicalise. 1381 | 1382 | ;; First sort by the start of each range. 1383 | (setq ranges (cl-sort ranges #'< :key #'car)) 1384 | ;; Then check for overlap. 1385 | (let ((ranges-without-overlap nil) 1386 | (pointer ranges)) 1387 | (while (cdr pointer) 1388 | (if (and (< (caar pointer) (cl-caadr pointer)) 1389 | (< (cdar pointer) (cl-cdadr pointer))) 1390 | (setq pointer (cdr pointer)) 1391 | (let ((start-of-new-range (cdr pointer))) 1392 | (setf (cdr pointer) nil) 1393 | (setq ranges-without-overlap 1394 | (gnus-range-add ranges-without-overlap ranges)) 1395 | (setq ranges start-of-new-range) 1396 | (setq pointer ranges)))) 1397 | (setq ranges-without-overlap 1398 | (gnus-range-add ranges-without-overlap ranges)) 1399 | ranges-without-overlap))) 1400 | 1401 | (defun bic-connection--has-capability (capability connection) 1402 | "Return non-nil if CAPABILITY was reported by CONNECTION. 1403 | Authentication methods cannot be queried." 1404 | (and (member capability (plist-get (fsm-get-state-data connection) 1405 | :capabilities)) 1406 | (not (member capability bic-ignored-capabilities)))) 1407 | 1408 | (defun bic-connection--latest-received (connection) 1409 | "Return the timestamp when CONNECTION last received data. 1410 | The timestamp is returned in the same format as `current-time'. 1411 | May return nil." 1412 | (let ((proc (plist-get (fsm-get-state-data connection) :proc))) 1413 | (when (processp proc) 1414 | (process-get proc :latest-received)))) 1415 | 1416 | (defun bic-connection--accept-output (connection) 1417 | "Attempt to process incoming data from CONNECTION. 1418 | Return non-nil if any output was received." 1419 | (let ((proc (plist-get (fsm-get-state-data connection) :proc))) 1420 | (when (processp proc) 1421 | ;; According to the docstring, this should make Emacs read 1422 | ;; output for this process only, without running any timers. 1423 | (accept-process-output proc 0.01 nil 0)))) 1424 | 1425 | (provide 'bic-core) 1426 | ;;; bic-core.el ends here 1427 | -------------------------------------------------------------------------------- /bic-mailbox-tree.el: -------------------------------------------------------------------------------- 1 | ;;; bic-mailbox-tree.el --- display tree of mailboxes -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2015 Magnus Henoch 4 | 5 | ;; Author: Magnus Henoch 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Use tree-widget to display known accounts and their mailboxes. 23 | 24 | ;;; Code: 25 | 26 | (require 'tree-widget) 27 | 28 | ;;; Mailbox tree 29 | 30 | (defface bic-mailbox-tree-account-connected 31 | '((t (:inherit gnus-server-opened))) 32 | "Face used for connected accounts in mailbox tree." 33 | :group 'bic) 34 | 35 | (defface bic-mailbox-tree-account-disconnected 36 | '((t (:inherit gnus-server-denied))) 37 | "Face used for disconnected accounts in mailbox tree." 38 | :group 'bic) 39 | 40 | (defface bic-mailbox-tree-account-deactivated 41 | '((t (:inherit gnus-server-closed))) 42 | "Face used for deactivated accounts in mailbox tree." 43 | :group 'bic) 44 | 45 | (defface bic-mailbox-tree-mailbox-unlimited-sync-unread 46 | '((t (:inherit gnus-group-mail-1))) 47 | "Face used for fully synced mailboxes with unread messages in mailbox tree." 48 | :group 'bic) 49 | 50 | (defface bic-mailbox-tree-mailbox-unlimited-sync 51 | '((t (:inherit gnus-group-mail-1-empty))) 52 | "Face used for fully synced mailboxes in mailbox tree." 53 | :group 'bic) 54 | 55 | (defface bic-mailbox-tree-mailbox-partial-sync-unread 56 | '((t (:inherit gnus-group-mail-low))) 57 | "Face used for partially synced mailboxes in mailbox tree." 58 | :group 'bic) 59 | 60 | (defface bic-mailbox-tree-mailbox-partial-sync 61 | '((t (:inherit gnus-group-mail-low-empty))) 62 | "Face used for partially synced mailboxes in mailbox tree." 63 | :group 'bic) 64 | 65 | (defface bic-mailbox-tree-mailbox-unsubscribed 66 | '((t (:inherit gnus-group-news-low-empty))) 67 | "Face used for unsubscribed mailboxes in mailbox tree." 68 | :group 'bic) 69 | 70 | (defvar bic-mailbox-tree-mode-map 71 | (let ((map (make-sparse-keymap))) 72 | (set-keymap-parent map special-mode-map) 73 | (define-key map (kbd "RET") 'bic-mailbox-tree-press-button-on-current-line) 74 | (define-key map (kbd "s") 'bic-mailbox-tree-sync) 75 | (define-key map (kbd "u") 'bic-mailbox-tree-no-sync) 76 | map)) 77 | 78 | (define-derived-mode bic-mailbox-tree-mode special-mode "BIC mailbox tree" 79 | "Major mode for tree of IMAP mailboxes accessed by `bic'." 80 | (add-hook 'bic-account-state-update-functions 81 | 'bic-mailbox-tree--update-account-state) 82 | (add-hook 'bic-account-mailbox-update-functions 83 | 'bic-mailbox-tree--update-mailbox-state) 84 | (widget-minor-mode) 85 | (setq-local widget-global-map bic-mailbox-tree-mode-map)) 86 | 87 | (defun bic-mailbox-tree-press-button-on-current-line (&optional event) 88 | ;; checkdoc-params: (event) 89 | "Find button on current line and press it. 90 | By default, widget mode is too stingy about where the point has 91 | to be for the button press to count. Let's try to do what the 92 | user expects." 93 | (interactive "@d") 94 | (let ((button (bic--button-on-current-line))) 95 | (if (null button) 96 | (user-error "No button on this line") 97 | (widget-apply-action button event)))) 98 | 99 | (defun bic-mailbox-tree-sync () 100 | "Set sync level for mailbox on current line. 101 | If the mailbox is not being synced, set it to unlimited sync. 102 | If the mailbox is being synced, toggle betweed unlimited and 103 | partial sync." 104 | (interactive) 105 | ;; Need to get the button that has the mailbox name as a property, 106 | ;; not the tree widget button. 107 | (let* ((button (bic--button-on-current-line 108 | (lambda (b) (not (null (widget-get b :mailbox-name)))))) 109 | (account-name (and button (widget-get button :account-name))) 110 | (mailbox-name (and button (widget-get button :mailbox-name)))) 111 | (if (or (null button) 112 | (null account-name)) 113 | (user-error "No mailbox on this line") 114 | (let* ((mailbox-data 115 | (gethash mailbox-name (gethash account-name bic-account-mailbox-table))) 116 | (new-sync-level 117 | (cl-ecase (bic--infer-sync-level mailbox-data) 118 | ((nil :partial-sync) 119 | (message "Changing %s to unlimited sync" mailbox-name) 120 | 'unlimited-sync) 121 | (:unlimited-sync 122 | (message "Changing %s to partial sync" mailbox-name) 123 | 'partial-sync)))) 124 | (bic-mailbox-set-sync-level account-name mailbox-name new-sync-level))))) 125 | 126 | (defun bic-mailbox-tree-no-sync () 127 | "Set mailbox on current line to \"no sync\"." 128 | (interactive) 129 | (let* ((button (bic--button-on-current-line 130 | (lambda (b) (not (null (widget-get b :mailbox-name)))))) 131 | (account-name (and button (widget-get button :account-name))) 132 | (mailbox-name (and button (widget-get button :mailbox-name)))) 133 | (if (or (null button) 134 | (null account-name)) 135 | (user-error "No mailbox on this line") 136 | (message "Changing %s to no sync" mailbox-name) 137 | (bic-mailbox-set-sync-level account-name mailbox-name 'no-sync)))) 138 | 139 | (defun bic--button-on-current-line (&optional predicate) 140 | "Find and return a button on the current line, if any. 141 | If PREDICATE is non-nil, return the first button that 142 | satisifies PREDICATE." 143 | (save-excursion 144 | (forward-line 0) 145 | (let ((end (line-end-position)) 146 | (button-pos (point)) 147 | button) 148 | (while (and (null button) button-pos (< button-pos end)) 149 | (setq button (get-char-property button-pos 'button)) 150 | (when predicate 151 | (unless (funcall predicate button) 152 | (setq button nil))) 153 | (unless button 154 | (setq button-pos 155 | (next-single-char-property-change 156 | button-pos 'button nil (line-end-position))))) 157 | button))) 158 | 159 | ;;;###autoload 160 | (defun bic-mailbox-tree () 161 | "Show mailbox tree buffer." 162 | (interactive) 163 | (with-current-buffer (get-buffer-create "*Mailboxes*") 164 | (unless (derived-mode-p 'bic-mailbox-tree-mode) 165 | (bic-mailbox-tree-mode) 166 | (bic-mailbox-tree--init)) 167 | (switch-to-buffer (current-buffer)))) 168 | 169 | (defvar-local bic-mailbox-tree--widget nil) 170 | 171 | (defun bic-mailbox-tree--init () 172 | "Initialise a mailbox tree buffer." 173 | (unless bic-mailbox-tree--widget 174 | (setq bic-mailbox-tree--widget 175 | (widget-create 176 | 'tree-widget 177 | :tag "Accounts" 178 | :open t 179 | :expander #'bic-mailbox-tree--accounts 180 | :expander-p (lambda (&rest _) t))))) 181 | 182 | (defun bic-mailbox-tree--accounts (_parent) 183 | "Return tree widgets for all accounts." 184 | (mapcar 185 | (lambda (fsm) 186 | (let ((address (plist-get (fsm-get-state-data fsm) :address))) 187 | (bic-mailbox-tree--account address))) 188 | bic-running-accounts)) 189 | 190 | (defun bic-mailbox-tree--account (address) 191 | "Return a tree widget for the account named ADDRESS." 192 | (widget-convert 193 | 'tree-widget 194 | :tag (bic-mailbox-tree--account-tag address (gethash address bic-account-state-table)) 195 | :address address 196 | :expander #'bic-mailbox-tree--mailboxes 197 | :expander-p (lambda (&rest _) t))) 198 | 199 | (defun bic-mailbox-tree--account-tag (address state) 200 | "Return a \"tag\" for the account named ADDRESS based on its STATE. 201 | The tag consists of the address, followed by one of \"connected\", 202 | \"disconnected\" or \"deactivated\" in parentheses." 203 | (propertize 204 | (format "%s (%s)" address (substring (symbol-name state) 1)) 205 | 'face 206 | (cl-case state 207 | (:connected 'bic-mailbox-tree-account-connected) 208 | (:disconnected 'bic-mailbox-tree-account-disconnected) 209 | (:deactivated 'bic-mailbox-tree-account-deactivated)))) 210 | 211 | (defun bic-mailbox-tree--update-account-state (account new-state) 212 | "Update the state of ACCOUNT in the mailbox tree buffer. 213 | NEW-STATE is a keyword, one of :connected, :disconnected or 214 | :deactivated." 215 | (let ((buffer (get-buffer "*Mailboxes*"))) 216 | (when buffer 217 | (with-current-buffer buffer 218 | (let* ((children (widget-get bic-mailbox-tree--widget :children)) 219 | (account-widget 220 | (cl-find-if 221 | (lambda (child) 222 | (and (tree-widget-p child) 223 | (equal (widget-get child :address) account))) 224 | children))) 225 | (cond 226 | ((and account-widget new-state) 227 | ;; State change for existing account 228 | (let ((new-tag (bic-mailbox-tree--account-tag account new-state)) 229 | (node (car (widget-get account-widget :children)))) 230 | (if (null node) 231 | (warn "no node: %S" account-widget) 232 | ;; XXX: not sure why we need to put the tag in two places 233 | (widget-put account-widget :tag new-tag) 234 | (widget-put node :tag new-tag) 235 | ;; Redraw. 236 | (widget-value-set node (widget-value node))))) 237 | ((or 238 | ;; Account removed 239 | (and account-widget (null new-state)) 240 | ;; New account 241 | (and new-state (null account-widget))) 242 | ;; Just redraw the tree. TODO: it would be nice to 243 | ;; preserve the "open" state of tree nodes. 244 | (widget-value-set bic-mailbox-tree--widget (widget-value bic-mailbox-tree--widget))))))))) 245 | 246 | (defun bic-mailbox-tree--mailboxes (parent) 247 | "Return widgets for all mailboxes in an account. 248 | PARENT is the tree widget node for the account." 249 | (let* ((account-name (widget-get parent :address)) 250 | (mailbox-table (gethash account-name bic-account-mailbox-table)) 251 | mailboxes) 252 | (when mailbox-table 253 | (maphash 254 | (lambda (mailbox data) 255 | (push (cons mailbox data) mailboxes)) 256 | mailbox-table)) 257 | (setq mailboxes (cl-sort mailboxes #'string-lessp :key #'car)) 258 | (mapcar 259 | (lambda (mailbox-data) 260 | (let ((mailbox-name (car mailbox-data)) 261 | (attributes (plist-get (cdr mailbox-data) :attributes)) 262 | (sync-level (bic--infer-sync-level mailbox-data)) 263 | (unseen (plist-get (cdr mailbox-data) :unseen))) 264 | ;; It's unclear whether these attributes are case sensitive 265 | ;; or not, so let's use cl-equalp. 266 | (if (or (cl-member "\\Noselect" attributes :test #'cl-equalp) 267 | (cl-member "\\NonExistent" attributes :test #'cl-equalp)) 268 | (widget-convert 'item mailbox-name) 269 | (widget-convert 270 | 'link 271 | :account-name account-name 272 | :mailbox-name (car mailbox-data) 273 | :notify (lambda (widget &rest _ignore) 274 | (bic-mailbox-open (widget-get widget :account-name) 275 | (widget-get widget :mailbox-name))) 276 | :tag (if unseen (bic-number-to-string unseen) "?") 277 | :format (concat 278 | "%[%v%]" 279 | (when sync-level " (%t)") 280 | (cond 281 | ((plist-get (cdr mailbox-data) :not-all-unread) 282 | (propertize " [not all unread fetched]" 283 | 'face 'error)) 284 | ((plist-get (cdr mailbox-data) :not-all-recent) 285 | (propertize " [not all recent fetched]" 286 | 'face 'warning))) 287 | "\n") 288 | :button-face (pcase (cons sync-level (and (numberp unseen) (not (zerop unseen)))) 289 | (`(:unlimited-sync . t) 290 | 'bic-mailbox-tree-mailbox-unlimited-sync-unread) 291 | (`(:unlimited-sync . nil) 292 | 'bic-mailbox-tree-mailbox-unlimited-sync) 293 | (`(:partial-sync . t) 294 | 'bic-mailbox-tree-mailbox-partial-sync-unread) 295 | (`(:partial-sync . nil) 296 | 'bic-mailbox-tree-mailbox-partial-sync) 297 | (_ 298 | 'bic-mailbox-tree-mailbox-unsubscribed)) 299 | (utf7-decode mailbox-name t))))) 300 | mailboxes))) 301 | 302 | (defun bic-mailbox-tree--update-mailbox-state (account _mailbox _state) 303 | ;; checkdoc-params: (account) 304 | "Update the state of a mailbox in the mailbox tree buffer. 305 | This function is meant to be called from the hook 306 | `bic-account-mailbox-update-functions'." 307 | (let ((buffer (get-buffer "*Mailboxes*"))) 308 | (when buffer 309 | (with-current-buffer buffer 310 | ;; TODO: check mailbox non-nil 311 | (let ((account-widget 312 | (cl-find-if 313 | (lambda (child) 314 | (and (tree-widget-p child) 315 | (equal (widget-get child :address) account))) 316 | (widget-get bic-mailbox-tree--widget :children)))) 317 | (when account-widget 318 | (widget-value-set account-widget (widget-value account-widget)))))))) 319 | 320 | (provide 'bic-mailbox-tree) 321 | ;;; bic-mailbox-tree.el ends here 322 | -------------------------------------------------------------------------------- /bic-mailbox.el: -------------------------------------------------------------------------------- 1 | ;;; bic-mailbox.el --- list messages in a mailbox -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2015 Magnus Henoch 4 | 5 | ;; Author: Magnus Henoch 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Display messages in a mailbox using an ewoc. 23 | 24 | ;;; Code: 25 | 26 | (require 'ewoc) 27 | 28 | (defface bic-mailbox-unread 29 | '((t (:inherit gnus-summary-normal-unread))) 30 | "Face used for unread messages." 31 | :group 'bic) 32 | 33 | (defface bic-mailbox-read 34 | '((t (:inherit gnus-summary-normal-read))) 35 | "Face used for read messages." 36 | :group 'bic) 37 | 38 | (defface bic-mailbox-flagged 39 | '((t (:inherit gnus-summary-normal-ticked))) 40 | "Face used for flagged messages." 41 | :group 'bic) 42 | 43 | (defface bic-mailbox-spam 44 | '((t (:inherit spam))) 45 | "Face used for messages marked as spam." 46 | :group 'bic) 47 | 48 | (defface bic-mailbox-deleted 49 | '((t (:inherit gnus-summary-cancelled :strike-through t))) 50 | "Face used for messages marked for deletion." 51 | :group 'bic) 52 | 53 | (defface bic-mailbox-processable 54 | '((t (:inherit highlight))) 55 | "Face used for messages marked as processable." 56 | :group 'bic) 57 | 58 | (defvar-local bic-mailbox--ewoc nil) 59 | 60 | (defvar-local bic-mailbox--ewoc-nodes-table nil 61 | "Hash table mapping uidvalidity+uid to ewoc nodes.") 62 | 63 | (defvar-local bic-mailbox--hashtable nil) 64 | 65 | (defvar-local bic-mailbox--flags-table nil) 66 | 67 | (defvar-local bic-mailbox--uid-tree nil) 68 | 69 | (defvar-local bic-mailbox--fixup-times-timer nil) 70 | 71 | (defvar-local bic-mailbox--fixup-times-at nil) 72 | 73 | (defvar-local bic-mailbox--processable nil) 74 | 75 | ;;;###autoload 76 | (defun bic-mailbox-open (account mailbox) 77 | ;; checkdoc-order: nil 78 | "Open MAILBOX in a mailbox buffer. 79 | MAILBOX is the name of a mailbox belonging to ACCOUNT." 80 | (interactive 81 | (let* ((account (bic--read-existing-account "IMAP account: " t)) 82 | (mailbox (bic--read-mailbox "Mailbox: " account t))) 83 | (list account mailbox))) 84 | (let ((buffer-name (concat (utf7-decode mailbox t) "-" account))) 85 | (with-current-buffer (get-buffer-create buffer-name) 86 | (if (derived-mode-p 'bic-mailbox-mode) 87 | ;; If we already have a mailbox buffer for this mailbox, 88 | ;; ensure that it's up to date. 89 | (bic-mailbox-update) 90 | (bic-mailbox-mode) 91 | (bic-mailbox--init account mailbox))) 92 | (switch-to-buffer buffer-name))) 93 | 94 | ;;;###autoload 95 | (defun bic-mailbox--find-buffer (account mailbox) 96 | ;; checkdoc-order: nil 97 | "Return the buffer viewing MAILBOX for ACCOUNT. 98 | If there is no such buffer, return nil." 99 | (get-buffer (concat (utf7-decode mailbox t) "-" account))) 100 | 101 | (defvar bic-mailbox-mode-map 102 | (let ((map (make-sparse-keymap))) 103 | (set-keymap-parent map special-mode-map) 104 | (define-key map (kbd "RET") 'bic-mailbox-read-message) 105 | (define-key map "x" 'bic-mailbox-hide-read) 106 | (define-key map (kbd "M-g") 'bic-mailbox-update) 107 | (define-key map (kbd "d") 'bic-message-mark-read) 108 | (define-key map (kbd "M-u") 'bic-message-mark-unread) 109 | (define-key map "!" 'bic-message-mark-flagged) 110 | (define-key map (kbd "B DEL") 'bic-message-mark-deleted) 111 | (define-key map "$" 'bic-message-mark-spam) 112 | (define-key map "\M-$" 'bic-message-mark-not-spam) 113 | (define-key map "#" 'bic-mailbox-mark-processable) 114 | (define-key map (kbd "M-#") 'bic-mailbox-unmark-processable) 115 | (define-key map (kbd "C-M-#") 'bic-mailbox-unmark-all-processable) 116 | (define-key map "c" 'bic-mailbox-catchup) 117 | (define-key map "n" 'bic-mailbox-next-unread) 118 | (define-key map " " 'bic-mailbox-next-page-or-next-unread) 119 | (define-key map "=" 'bic-message-identify) 120 | map)) 121 | 122 | (define-derived-mode bic-mailbox-mode special-mode "BIC mailbox" 123 | "Major mode for IMAP mailboxes accessed by `bic'." 124 | (setq header-line-format 125 | '(" " bic--current-account 126 | " " (:eval (utf7-decode bic--current-mailbox t)) 127 | (:eval 128 | (let* ((mailbox-table 129 | (gethash bic--current-account bic-account-mailbox-table)) 130 | (mailbox-entry 131 | (and (hash-table-p mailbox-table) 132 | (gethash bic--current-mailbox mailbox-table)))) 133 | (cond 134 | ((plist-get mailbox-entry :not-all-unread) 135 | (propertize " [not all unread fetched]" 136 | 'face 'error)) 137 | ((plist-get mailbox-entry :not-all-recent) 138 | (propertize " [not all recent fetched]" 139 | 'face 'warning))))))) 140 | (setq-local revert-buffer-function #'bic-mailbox-reload) 141 | (setq-local truncate-lines t) 142 | (unless bic-mailbox--processable 143 | (setq bic-mailbox--processable (make-hash-table :test 'equal)))) 144 | 145 | (defun bic-mailbox--init (account mailbox) 146 | ;; checkdoc-params: (account mailbox) 147 | "Initialise a new mailbox buffer." 148 | (setq bic--current-account account 149 | bic--current-mailbox mailbox 150 | ;; TODO: use bic--mailbox-dir 151 | bic--dir (expand-file-name 152 | (bic--sanitize-mailbox-name mailbox) 153 | (expand-file-name 154 | account bic-data-directory))) 155 | (let ((inhibit-read-only t)) 156 | (erase-buffer) 157 | (setq bic-mailbox--ewoc 158 | (ewoc-create #'bic-mailbox--pp)) 159 | (setq bic-mailbox--ewoc-nodes-table 160 | (make-hash-table :test 'equal :weakness 'value)) 161 | (bic-mailbox--load-messages))) 162 | 163 | (defun bic-mailbox--load-messages () 164 | "Add list of messages to mailbox buffer." 165 | (let* ((uidvalidity-file (expand-file-name "uidvalidity" bic--dir)) 166 | (uidvalidity 167 | (when (file-exists-p uidvalidity-file) 168 | (with-temp-buffer 169 | (insert-file-contents-literally uidvalidity-file) 170 | (buffer-string)))) 171 | (buffer (current-buffer))) 172 | (fsm-send 173 | (bic--find-account bic--current-account) 174 | (list :get-mailbox-tables bic--current-mailbox) 175 | (lambda (tables) 176 | (with-current-buffer buffer 177 | (setq bic-mailbox--hashtable (cl-first tables)) 178 | (setq bic-mailbox--flags-table (cl-second tables)) 179 | (setq bic-mailbox--uid-tree (cl-third tables)) 180 | (let ((inhibit-read-only t)) 181 | (avl-tree-mapc 182 | (lambda (bare-uid) 183 | (let ((full-uid (concat uidvalidity "-" (bic-number-to-string bare-uid)))) 184 | (puthash 185 | full-uid (ewoc-enter-last bic-mailbox--ewoc full-uid) 186 | bic-mailbox--ewoc-nodes-table))) 187 | bic-mailbox--uid-tree))))) 188 | (fsm-send 189 | (bic--find-account bic--current-account) 190 | (list :ensure-up-to-date bic--current-mailbox)))) 191 | 192 | (defun bic-mailbox--pp (msg) 193 | ;; checkdoc-params: (msg) 194 | "Ewoc pretty-printer function for mailbox buffer." 195 | (let ((envelope (gethash msg bic-mailbox--hashtable)) 196 | (flags (gethash msg bic-mailbox--flags-table)) 197 | (processable (and bic-mailbox--processable 198 | (gethash msg bic-mailbox--processable)))) 199 | (pcase envelope 200 | (`(,date ,subject (,from . ,_) . ,_) 201 | ;; TODO: nicer format 202 | (cl-flet ((col (n) (propertize " " 'display `(space :align-to ,n)))) 203 | (insert 204 | (propertize 205 | (concat 206 | (bic-mailbox--format-flags flags processable) 207 | (col 3) (bic-mailbox--format-date date) 208 | (col 16) "[ " 209 | (truncate-string-to-width 210 | (if (member (car from) '("" "NIL")) 211 | (concat (nth 2 from) "@" (nth 3 from)) 212 | (rfc2047-decode-string (car from))) 213 | 20) 214 | (col 39) "] " 215 | (rfc2047-decode-string subject)) 216 | 'face (bic-mailbox--face-from-flags flags processable))))) 217 | (`nil 218 | (warn "Message %s not found in hash table" msg))))) 219 | 220 | (defun bic-mailbox--face-from-flags (flags processable) 221 | "Return the font face to use for a message, based on FLAGS and PROCESSABLE." 222 | (let ((flag-face 223 | (cond 224 | ((member "\\Deleted" flags) 225 | 'bic-mailbox-deleted) 226 | ((member "$Junk" flags) 227 | 'bic-mailbox-spam) 228 | ((member "\\Flagged" flags) 229 | 'bic-mailbox-flagged) 230 | ((member "\\Seen" flags) 231 | 'bic-mailbox-read) 232 | (t 233 | 'bic-mailbox-unread)))) 234 | (if processable 235 | (list 'bic-mailbox-processable flag-face) 236 | flag-face))) 237 | 238 | (defun bic-mailbox--format-flags (flags processable) 239 | "Return indicators to use for a message, given FLAGS. 240 | The indicators consist of two characters. First character: 241 | 242 | - If the message is marked as spam: $ 243 | - If the message is flagged: ! 244 | - If the message is read: R 245 | - If the message is recent: . 246 | - Otherwise, the first character is a space 247 | 248 | Second character: 249 | 250 | - If the message is marked as PROCESSABLE: # 251 | - If the message has been answered: A 252 | - If the message has been forwarded: F 253 | - Otherwise, the second character is a space" 254 | (propertize 255 | (format "%c%c" 256 | (cond 257 | ((member "$Junk" flags) 258 | ?$) 259 | ((member "\\Flagged" flags) 260 | ?!) 261 | ((member "\\Seen" flags) 262 | ?R) 263 | ((member "\\Recent" flags) 264 | ?.) 265 | (t 266 | ?\s)) 267 | (cond 268 | (processable 269 | ?#) 270 | ((member "\\Answered" flags) 271 | ?A) 272 | ((member "$Forwarded" flags) 273 | ?F) 274 | (t 275 | ?\s))) 276 | 'help-echo (concat "Flags: " 277 | (if flags 278 | (mapconcat 'identity (remq :pending flags) ", ") 279 | "none")))) 280 | 281 | (defun bic-mailbox--format-date (date) 282 | "Format DATE for mailbox message listing. 283 | If the message was sent today, show the time as HH:MM. 284 | If the message was sent within the last 180 days, 285 | show the date as DD MMM (abbreviated month). 286 | Otherwise, show a numeric date as YYYY-MM-DD." 287 | (let ((parsed-date (ignore-errors (date-to-time date)))) 288 | (if (null date) 289 | ;; cannot parse 290 | "**********" 291 | (let* ((now (time-to-days (current-time))) 292 | (days (- now (time-to-days parsed-date)))) 293 | (cond 294 | ((= days 0) 295 | ;; same day: show time 296 | (prog1 297 | (propertize (format-time-string " %H:%M" parsed-date) 298 | 'bic-mailbox--timestamp-without-date now) 299 | ;; Remember that we wrote a time-only date. 300 | (unless (and bic-mailbox--fixup-times-at (<= bic-mailbox--fixup-times-at now)) 301 | ;; Need to fix this time tomorrow. 302 | (setq bic-mailbox--fixup-times-at (1+ now))) 303 | (bic-mailbox--fixup-times-maybe-start-timer))) 304 | ((< days 180) 305 | ;; less than half a year ago: show date without year 306 | (format "%10s" (format-time-string "%e %b" parsed-date))) 307 | (t 308 | ;; more than half a year ago, or in the future: show YYYY-MM-DD 309 | (format-time-string "%F" parsed-date))))))) 310 | 311 | (defun bic-mailbox--fixup-times (buffer) 312 | "At midnight, update message timestamps in BUFFER. 313 | Any message that was showing just the time will be 314 | updated to show the date instead, since it's already 315 | from yesterday." 316 | (when (buffer-live-p buffer) 317 | (with-current-buffer buffer 318 | (unless (derived-mode-p 'bic-mailbox-mode) 319 | (error "Not a mailbox buffer")) 320 | (let ((now (time-to-days (current-time))) 321 | (pos (point-min)) 322 | (node nil) 323 | (have-more nil)) 324 | (while (setq pos (next-single-property-change pos 'bic-mailbox--timestamp-without-date)) 325 | (let ((day (get-text-property pos 'bic-mailbox--timestamp-without-date))) 326 | (when (numberp day) 327 | (cond 328 | ((< day now) 329 | (setq node (ewoc-locate bic-mailbox--ewoc pos node)) 330 | (bic-mailbox--invalidate bic-mailbox--ewoc node)) 331 | ((= day now) 332 | (setq have-more t)))))) 333 | (if have-more 334 | (progn 335 | (setq bic-mailbox--fixup-times-at (1+ now)) 336 | (bic-mailbox--fixup-times-maybe-start-timer)) 337 | (setq bic-mailbox--fixup-times-at nil 338 | bic-mailbox--fixup-times-timer nil)))))) 339 | 340 | (defun bic-mailbox--fixup-times-maybe-start-timer () 341 | "Set timer for fixing message timestamps. 342 | At midnight, we change HH:MM timestamps for messages sent 343 | today into the format for messages sent earlier. 344 | See `bic-mailbox--fixup-times'." 345 | (unless (or 346 | ;; If there's already a timer that's set to run in the 347 | ;; future, there's no need to set a new one. 348 | (and (timerp bic-mailbox--fixup-times-timer) 349 | (> 0 (timer-until bic-mailbox--fixup-times-timer (current-time)))) 350 | ;; Also check that there's a time when the timer needs to 351 | ;; be run. 352 | (null bic-mailbox--fixup-times-at)) 353 | (let* ((utc-midnight 354 | ;; NB: `bic-mailbox--fixup-times-at' was returned from 355 | ;; `time-to-days', which returns the number of days from 356 | ;; year 1. However, `days-to-time' expects as its argument 357 | ;; the number of days since the epoch. Thus, we need to 358 | ;; adjust the value. 359 | 360 | ;; That gives us UTC midnight of the given day. 361 | (days-to-time (- bic-mailbox--fixup-times-at 362 | (time-to-days 0)))) 363 | (local-midnight 364 | ;; Then we need to subtract the time zone offset, to get 365 | ;; the local midnight. 366 | (time-subtract utc-midnight (or (car (current-time-zone utc-midnight)) 0)))) 367 | (setq bic-mailbox--fixup-times-timer 368 | (run-at-time 369 | local-midnight 370 | nil 371 | 'bic-mailbox--fixup-times (current-buffer)))))) 372 | 373 | (defun bic-mailbox-hide-read () 374 | "Hide messages that are marked as read, but not flagged. 375 | Also hide messages marked for deletion." 376 | (interactive) 377 | (unless (derived-mode-p 'bic-mailbox-mode) 378 | (user-error "Not a mailbox buffer")) 379 | (ewoc-filter 380 | bic-mailbox--ewoc 381 | (lambda (full-uid) 382 | (let* ((flags (gethash full-uid bic-mailbox--flags-table))) 383 | (and (not (member "\\Deleted" flags)) 384 | (or (member "\\Flagged" flags) 385 | (not (member "\\Seen" flags)))))))) 386 | 387 | (defun bic-mailbox-catchup () 388 | "Mark all visible unread messages as read." 389 | (interactive) 390 | (unless (derived-mode-p 'bic-mailbox-mode) 391 | (user-error "Not a mailbox buffer")) 392 | (let ((messages nil) 393 | (count 0)) 394 | (ewoc-map 395 | (lambda (full-uid) 396 | (unless (member "\\Seen" (gethash full-uid bic-mailbox--flags-table)) 397 | (push full-uid messages) 398 | (cl-incf count)) 399 | nil) 400 | bic-mailbox--ewoc) 401 | (if (null messages) 402 | (message "All visible messages are already marked as read; nothing to catchup") 403 | (if (y-or-n-p (format "Mark %d messages in %s as read? " count bic--current-mailbox)) 404 | (let ((fsm (bic--find-account bic--current-account))) 405 | ;; TODO: it would be nice to send all UIDs to the FSM in a 406 | ;; single message. 407 | (dolist (full-uid messages) 408 | (fsm-send 409 | fsm 410 | (list :flags bic--current-mailbox full-uid '("\\Seen") ())))) 411 | (message "Catchup cancelled"))))) 412 | 413 | (defun bic-mailbox-reload (&optional _ignore-auto _noconfirm) 414 | "Reload messages for the current mailbox buffer." 415 | (interactive) 416 | (unless (derived-mode-p 'bic-mailbox-mode) 417 | (user-error "Not a mailbox buffer")) 418 | (let ((inhibit-read-only t)) 419 | ;; First, remove all elements from the ewoc. 420 | (ewoc-filter bic-mailbox--ewoc #'ignore) 421 | ;; Then reload. 422 | (bic-mailbox--load-messages))) 423 | 424 | (defun bic-mailbox-update () 425 | "Fetch new messages in current mailbox from server." 426 | (interactive) 427 | (unless (derived-mode-p 'bic-mailbox-mode) 428 | (user-error "Not a mailbox buffer")) 429 | (fsm-send (bic--find-account bic--current-account) 430 | `(:ensure-up-to-date ,bic--current-mailbox :verbose t))) 431 | 432 | (defun bic-mailbox-read-message (keep-unread) 433 | ;; checkdoc-params: (keep-unread) 434 | "Open the message under point, and mark it as read. 435 | With prefix argument, don't mark message as read." 436 | (interactive "P") 437 | (unless (derived-mode-p 'bic-mailbox-mode) 438 | (user-error "Not a mailbox buffer")) 439 | (let ((msg (ewoc-data (ewoc-locate bic-mailbox--ewoc (point))))) 440 | (bic-message-display bic--current-account 441 | bic--current-mailbox 442 | msg) 443 | (unless keep-unread 444 | (bic-message-flag '("\\Seen") '() msg)))) 445 | 446 | ;;;###autoload 447 | (defun bic-mailbox-next-unread () 448 | "Open the next unread message." 449 | (interactive) 450 | (let (mailbox-buffer current-node) 451 | (cond 452 | ((derived-mode-p 'bic-mailbox-mode) 453 | (setq current-node (ewoc-locate bic-mailbox--ewoc) 454 | mailbox-buffer (current-buffer))) 455 | ((derived-mode-p 'bic-message-mode) 456 | (setq mailbox-buffer (bic-mailbox--find-buffer 457 | bic--current-account bic--current-mailbox)) 458 | (unless mailbox-buffer 459 | (user-error "Cannot find mailbox buffer for %s of %s" 460 | bic--current-mailbox bic--current-account)) 461 | (setq current-node 462 | (gethash bic-message--full-uid 463 | (buffer-local-value 'bic-mailbox--ewoc-nodes-table mailbox-buffer)))) 464 | (t 465 | (user-error "Not in message or mailbox buffer"))) 466 | (with-current-buffer mailbox-buffer 467 | (let ((next-node current-node)) 468 | (while 469 | (progn 470 | (setq next-node (ewoc-next bic-mailbox--ewoc next-node)) 471 | (and next-node 472 | (member "\\Seen" 473 | (gethash (ewoc-data next-node) bic-mailbox--flags-table))))) 474 | (unless next-node 475 | (user-error "No more unread messages")) 476 | (let ((mailbox-window (get-buffer-window mailbox-buffer))) 477 | ;; Complicated dance to ensure that we advance point 478 | ;; regardless of whether the mailbox buffer is visible or 479 | ;; not. 480 | (if mailbox-window 481 | (with-selected-window mailbox-window 482 | (ewoc-goto-node bic-mailbox--ewoc next-node)) 483 | (ewoc-goto-node bic-mailbox--ewoc next-node))) 484 | (bic-mailbox-read-message nil))))) 485 | 486 | ;;;###autoload 487 | (defun bic-mailbox-next-page-or-next-unread () 488 | "Show next page of message. 489 | If at the end of the message, show next unread message." 490 | (interactive) 491 | (let* ((message-buffer (get-buffer "*BIC-Message*")) 492 | (message-window (and message-buffer (get-buffer-window message-buffer)))) 493 | (if (null message-window) 494 | ;; No message is being displayed; open the next one. 495 | (bic-mailbox-next-unread) 496 | ;; Message displayed; scroll or move to next. 497 | (with-selected-window message-window 498 | (when (gnus-article-next-page) 499 | (bic-mailbox-next-unread)))))) 500 | 501 | ;;;###autoload 502 | (defun bic-mailbox--maybe-update-message (address mailbox full-uid) 503 | ;; checkdoc-params: (address mailbox full-uid) 504 | "Update how a certain message is displayed in its mailbox buffer. 505 | If there is no mailbox buffer for the mailbox in question, do nothing." 506 | (pcase (bic-mailbox--find-buffer address mailbox) 507 | ((and (pred bufferp) mailbox-buffer) 508 | (run-with-idle-timer 509 | 0.1 nil 'bic-mailbox--update-message mailbox-buffer full-uid)))) 510 | 511 | (defun bic-mailbox--update-message (buffer full-uid) 512 | "Update the display of a message in a mailbox buffer. 513 | BUFFER is the buffer displaying the mailbox, and FULL-UID 514 | is a string containing the uidvalidity and the uid of the 515 | message. 516 | 517 | If the message is currently not displayed, add it to the end 518 | of the buffer. If the message is displayed, call the ewoc 519 | pretty-printer again to update display for new flags etc." 520 | (with-current-buffer buffer 521 | (pcase (gethash full-uid bic-mailbox--ewoc-nodes-table) 522 | (`nil 523 | ;; Not found; add to end of buffer. 524 | ;; TODO: respect existing restrictions, such as "only unread" 525 | (puthash 526 | full-uid (ewoc-enter-last bic-mailbox--ewoc full-uid) 527 | bic-mailbox--ewoc-nodes-table)) 528 | (node 529 | (when (ewoc-location node) 530 | (bic-mailbox--invalidate bic-mailbox--ewoc node)))))) 531 | 532 | (defun bic-mailbox--invalidate (ewoc node) 533 | ;; checkdoc-params: (ewoc node) 534 | "Like `ewoc-invalidate', but ensure point doesn't move. 535 | Assumes that the size of the entry won't change." 536 | (let ((old-point (point))) 537 | ;; We use an integer instead of a marker, because we don't 538 | ;; expect the size of the entry to change, and if point was 539 | ;; on this entry or immediately after it, we would lose the 540 | ;; precise position and instead go back to the start of the 541 | ;; entry if we used a marker. 542 | (unwind-protect 543 | (ewoc-invalidate ewoc node) 544 | (goto-char old-point)))) 545 | 546 | ;;;###autoload 547 | (defun bic-mailbox--maybe-remove-message (address mailbox full-uid) 548 | ;; checkdoc-params: (address mailbox full-uid) 549 | "Remove a message from its mailbox buffer. 550 | If there is no buffer displaying the mailbox in question, do nothing." 551 | (pcase (bic-mailbox--find-buffer address mailbox) 552 | ((and (pred bufferp) mailbox-buffer) 553 | (run-with-idle-timer 554 | 0.1 nil 'bic-mailbox--remove-message mailbox-buffer full-uid)))) 555 | 556 | (defun bic-mailbox--remove-message (buffer full-uid) 557 | "Remove a message from BUFFER. 558 | FULL-UID is a string containing the uidvalidity and the uid of the 559 | message." 560 | (with-current-buffer buffer 561 | (remhash full-uid bic-mailbox--processable) 562 | (pcase (gethash full-uid bic-mailbox--ewoc-nodes-table) 563 | (`nil 564 | ;; Not found; nothing to do. 565 | ) 566 | (node 567 | (when (ewoc-location node) 568 | (let ((inhibit-read-only t)) 569 | (ewoc-delete bic-mailbox--ewoc node))))))) 570 | 571 | (defun bic-mailbox-mark-processable () 572 | (interactive) 573 | "Mark the current message as processable and move to the next message." 574 | (unless (derived-mode-p 'bic-mailbox-mode) 575 | (user-error "Not in mailbox buffer")) 576 | (let ((full-uid (bic--find-message-at-point))) 577 | (puthash full-uid t bic-mailbox--processable) 578 | (bic-mailbox--update-message (current-buffer) full-uid) 579 | (ignore-errors (ewoc-goto-next bic-mailbox--ewoc 1)))) 580 | 581 | (defun bic-mailbox-unmark-processable () 582 | (interactive) 583 | "Remove the processable mark from the current message and move to the next message." 584 | (unless (derived-mode-p 'bic-mailbox-mode) 585 | (user-error "Not in mailbox buffer")) 586 | (let ((full-uid (bic--find-message-at-point))) 587 | (remhash full-uid bic-mailbox--processable) 588 | (bic-mailbox--update-message (current-buffer) full-uid) 589 | (ignore-errors (ewoc-goto-next bic-mailbox--ewoc 1)))) 590 | 591 | (defun bic-mailbox-unmark-all-processable () 592 | (interactive) 593 | "Remove the processable mark from all messages in the current mailbox." 594 | (unless (derived-mode-p 'bic-mailbox-mode) 595 | (user-error "Not in mailbox buffer")) 596 | (let (previously-processable) 597 | (maphash (lambda (full-uid _value) (push full-uid previously-processable)) 598 | bic-mailbox--processable) 599 | (clrhash bic-mailbox--processable) 600 | (dolist (full-uid previously-processable) 601 | (bic-mailbox--update-message (current-buffer) full-uid)))) 602 | 603 | (provide 'bic-mailbox) 604 | ;;; bic-mailbox.el ends here 605 | -------------------------------------------------------------------------------- /bic-message.el: -------------------------------------------------------------------------------- 1 | ;;; bic-message.el --- display a message -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2015 Magnus Henoch 4 | 5 | ;; Author: Magnus Henoch 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; 23 | 24 | ;;; Code: 25 | 26 | (defvar-local bic-message--full-uid nil 27 | "String containing uidvalidity and uid for message displayed in buffer.") 28 | 29 | (defvar bic-message-mode-map 30 | ;; gnus-article-mode-map sets widget-keymap as its parent. I'm not 31 | ;; yet ready to give up special-mode-map, so let's start out with a 32 | ;; copy of widget-keymap instead. This lets us tab between elements 33 | ;; and hit RET to activate links etc. 34 | (let ((map (copy-keymap widget-keymap))) 35 | (set-keymap-parent map special-mode-map) 36 | ;; XXX: mark as replied, insert body, etc 37 | (define-key map "r" 'bic-message-reply) 38 | (define-key map "f" 'bic-message-wide-reply) 39 | (define-key map (kbd "C-c C-f") 'bic-message-forward) 40 | (define-key map "d" 'bic-message-mark-read) 41 | (define-key map (kbd "M-u") 'bic-message-mark-unread) 42 | (define-key map "!" 'bic-message-mark-flagged) 43 | (define-key map (kbd "B DEL") 'bic-message-mark-deleted) 44 | (define-key map "$" 'bic-message-mark-spam) 45 | (define-key map "\M-$" 'bic-message-mark-not-spam) 46 | ;; (define-key map (kbd "RET") 'bic-mailbox-read-message) 47 | (define-key map "t" 'bic-message-toggle-header) 48 | (define-key map "W" 'gnus-summary-wash-map) 49 | (define-key map "n" 'bic-mailbox-next-unread) 50 | (define-key map " " 'bic-mailbox-next-page-or-next-unread) 51 | (define-key map "g" 'bic-message-reload) 52 | (define-key map "=" 'bic-message-identify) 53 | map)) 54 | 55 | (define-derived-mode bic-message-mode gnus-article-mode "BIC Message" 56 | "Major mode for messages viewed from `bic'. 57 | 58 | Useful key bindings: 59 | \\ 60 | key\taction 61 | ---\t------- 62 | \\[bic-message-mark-read]\tMark read 63 | \\[bic-message-mark-unread]\tMark unread 64 | \\[bic-message-mark-flagged]\tMark as \"flagged\" 65 | 66 | \\[bic-message-reply]\tReply 67 | \\[bic-message-wide-reply]\tReply all 68 | \\[bic-message-forward]\tForward 69 | 70 | \\[bic-message-toggle-header]\tToggle displaying full message headers 71 | 72 | All key bindings: 73 | 74 | \\{bic-message-mode-map}") 75 | 76 | ;;;###autoload 77 | (cl-defun bic-message-display (account mailbox msg &key raw) 78 | "Display a message in the buffer *BIC-Message*. 79 | ACCOUNT and MAILBOX identify the mailbox that the message is in, 80 | and MSG is a string, containing the uidvalidity of the mailbox 81 | and the uid of the message, separated by a hyphen." 82 | (with-current-buffer (get-buffer-create "*BIC-Message*") 83 | (let ((inhibit-read-only t)) 84 | (bic-message-mode) 85 | ;; Don't ask :( 86 | (setq-local gnus-summary-buffer 87 | (or (bic-mailbox--find-buffer account mailbox) 88 | (current-buffer))) 89 | (setq-local gnus-article-buffer (current-buffer)) 90 | (setq bic--current-account account 91 | bic--current-mailbox mailbox 92 | bic-message--full-uid msg 93 | bic--dir (expand-file-name 94 | ;; TODO: use bic--mailbox-dir 95 | (bic--sanitize-mailbox-name mailbox) 96 | (expand-file-name 97 | account bic-data-directory))) 98 | ;; Keep the original text of the message in a separate buffer. 99 | (let ((dir bic--dir)) 100 | (with-current-buffer (get-buffer-create gnus-original-article-buffer) 101 | (erase-buffer) 102 | (remove-overlays) 103 | (insert-file-contents-literally 104 | (expand-file-name msg dir) nil nil nil t) 105 | (decode-coding-region (point-min) (point-max) 'raw-text-dos) 106 | ;; "Original" but still decoded. 107 | (run-hooks 'gnus-article-decode-hook))) 108 | (erase-buffer) 109 | (remove-overlays) 110 | ;; NB: gnus-article-mode gets very confused by CRLF line endings. 111 | ;; TODO: be more clever about what we decode. Binary attachments? 112 | (insert-file-contents-literally 113 | (expand-file-name msg bic--dir) nil nil nil t) 114 | (decode-coding-region (point-min) (point-max) 'raw-text-dos) 115 | (unless raw 116 | ;; Gnus already does a fine job displaying messages, so we might 117 | ;; as well piggy-back on that: 118 | (run-hooks 'gnus-article-decode-hook) 119 | (gnus-article-prepare-display))) 120 | (let ((window (display-buffer (current-buffer)))) 121 | (set-window-start window (point-min))))) 122 | 123 | (defun bic-message-reload (&optional raw) 124 | "Redisplay the current message. 125 | With prefix argument (or when RAW is non-nil), 126 | display the raw data of the message." 127 | (interactive "P") 128 | (unless (derived-mode-p 'bic-message-mode) 129 | (user-error "Not in message buffer")) 130 | (bic-message-display 131 | bic--current-account 132 | bic--current-mailbox 133 | bic-message--full-uid 134 | :raw (if raw t nil))) 135 | 136 | (defun bic-message-toggle-header (&optional arg) 137 | "Show the headers if they are hidden, or hide them if they are shown. 138 | If ARG is a positive number, show the entire header. 139 | If ARG is a negative number, hide the unwanted header lines." 140 | (interactive "P") 141 | (cl-letf (((symbol-function 'gnus-set-mode-line) #'ignore)) 142 | (gnus-summary-toggle-header arg))) 143 | 144 | ;;;###autoload 145 | (defun bic-message-identify () 146 | "Display the UID, mailbox and account of the current message. 147 | The \"current\" message is the one displayed in a message buffer, 148 | or the message under point in a mailbox buffer." 149 | (interactive) 150 | (let ((full-uid (bic--find-message-at-point))) 151 | (message "Message %s, in mailbox %s, account %s" 152 | full-uid bic--current-mailbox bic--current-account))) 153 | 154 | ;;;###autoload 155 | (defun bic-message-mark-read () 156 | "Mark the message at point as read. 157 | If the message is marked as flagged, remove the flag. 158 | If the message is marked to be deleted, undelete it. 159 | 160 | In a mailbox buffer, if the region is active, act on all messages in 161 | the region." 162 | (interactive) 163 | (bic-message-flag-maybe-advance "read" '("\\Seen") '("\\Flagged" "\\Deleted"))) 164 | 165 | ;;;###autoload 166 | (defun bic-message-mark-unread () 167 | "Mark the message at point as unread. 168 | If the message is marked as flagged, remove the flag. 169 | If the message is marked to be deleted, undelete it. 170 | 171 | In a mailbox buffer, if the region is active, act on all messages in 172 | the region." 173 | (interactive) 174 | (bic-message-flag-maybe-advance "unread" () '("\\Seen" "\\Flagged" "\\Deleted"))) 175 | 176 | ;;;###autoload 177 | (defun bic-message-mark-flagged () 178 | "Mark the message at point as flagged. 179 | Also mark it as read. 180 | If the message is marked to be deleted, undelete it. 181 | 182 | In a mailbox buffer, if the region is active, act on all messages in 183 | the region." 184 | (interactive) 185 | (bic-message-flag-maybe-advance "flagged" '("\\Seen" "\\Flagged") '("\\Deleted"))) 186 | 187 | ;;;###autoload 188 | (defun bic-message-mark-spam () 189 | "Mark the message at point as spam (junk). 190 | 191 | In a mailbox buffer, if the region is active, act on all messages in 192 | the region." 193 | (interactive) 194 | (bic-message-flag-maybe-advance "spam" '("$Junk") '("$NotJunk"))) 195 | 196 | ;;;###autoload 197 | (defun bic-message-mark-not-spam () 198 | "Mark the message at point as not spam (not junk). 199 | 200 | In a mailbox buffer, if the region is active, act on all messages in 201 | the region." 202 | (interactive) 203 | (bic-message-flag-maybe-advance "not spam" '("$NotJunk") '("$Junk"))) 204 | 205 | ;;;###autoload 206 | (defun bic-message-mark-deleted () 207 | "Mark the message at point for deletion. 208 | 209 | In a mailbox buffer, if the region is active, act on all messages in 210 | the region." 211 | (interactive) 212 | (bic-message-flag-maybe-advance "deleted" '("\\Deleted") ())) 213 | 214 | ;;;###autoload 215 | (defun bic-message-flag (flags-to-add flags-to-remove &optional full-uid) 216 | "Add and remove flags for the message at point. 217 | FLAGS-TO-ADD and FLAGS-TO-REMOVE are lists of strings. 218 | If FULL-UID is specified, use that message instead of 219 | the message at point." 220 | (let ((full-uid (or full-uid (bic--find-message-at-point))) 221 | (fsm (bic--find-account bic--current-account))) 222 | (fsm-send 223 | fsm 224 | (list :flags bic--current-mailbox full-uid flags-to-add flags-to-remove)))) 225 | 226 | (defun bic-message-flag-maybe-advance (human-readable flags-to-add flags-to-remove) 227 | "Add and remove flags, and maybe advance to next message. 228 | If point is in a mailbox buffer (not a message buffer), 229 | move point to the next message. 230 | HUMAN-READABLE is a string to be used when prompting to confirm. 231 | FLAGS-TO-ADD and FLAGS-TO-REMOVE are lists of strings. 232 | 233 | If in a mailbox buffer and the region is active, act on all 234 | messages in the region. 235 | Otherwise, if some messages are marked as processable, act 236 | on those messages." 237 | (cond 238 | ((and (derived-mode-p 'bic-mailbox-mode) (use-region-p)) 239 | (let* ((first (ewoc-locate bic-mailbox--ewoc (region-beginning))) 240 | (last (ewoc-locate bic-mailbox--ewoc (1- (region-end)) first)) 241 | nodes 242 | (count 0)) 243 | (unless (and first last) 244 | (user-error "No message at point or mark")) 245 | (while last 246 | (push last nodes) 247 | (cl-incf count) 248 | (setq last (when (not (eq last first)) 249 | (ewoc-prev bic-mailbox--ewoc last)))) 250 | (unless (yes-or-no-p (format "Mark %d messages as %s? " count human-readable)) 251 | (signal 'quit nil)) 252 | (setq deactivate-mark t) 253 | (dolist (node nodes) 254 | (bic-message-flag flags-to-add flags-to-remove (ewoc-data node))))) 255 | ((and (derived-mode-p 'bic-mailbox-mode) 256 | (> (hash-table-count bic-mailbox--processable) 0)) 257 | (unless (yes-or-no-p (format "Mark %d messages as %s? " 258 | (hash-table-count bic-mailbox--processable) 259 | human-readable)) 260 | (signal 'quit nil)) 261 | (maphash 262 | (lambda (full-uid _value) 263 | (bic-message-flag flags-to-add flags-to-remove full-uid)) 264 | bic-mailbox--processable)) 265 | (t 266 | (bic-message-flag flags-to-add flags-to-remove) 267 | (when (derived-mode-p 'bic-mailbox-mode) 268 | (ignore-errors (ewoc-goto-next bic-mailbox--ewoc 1)))))) 269 | 270 | (defun bic-message-reply (&optional wide) 271 | "Compose a reply to the current message. 272 | If WIDE is non-nil, address the reply to all recipients 273 | as well as the sender of the original message (known as 274 | \"reply all\" in other email clients)." 275 | (interactive) 276 | (unless (derived-mode-p 'bic-message-mode) 277 | (user-error "Not in message buffer")) 278 | (let ((full-uid (bic--find-message-at-point)) 279 | (mailbox bic--current-mailbox) 280 | (account bic--current-account)) 281 | (let (gnus-buffers) ;don't ask :( 282 | (gnus-copy-article-buffer gnus-original-article-buffer)) 283 | (message-reply nil wide) 284 | (add-to-list 285 | 'message-send-actions 286 | (lambda () 287 | (fsm-send 288 | (bic--find-account account) 289 | (list :flags mailbox full-uid '("\\Answered") ())))))) 290 | 291 | (defun bic-message-wide-reply () 292 | "Compose a wide reply (\"reply all\") to the current message." 293 | (interactive) 294 | (bic-message-reply t)) 295 | 296 | (defun bic-message-forward () 297 | "Forward the current message." 298 | (interactive) 299 | (unless (derived-mode-p 'bic-message-mode) 300 | (user-error "Not in message buffer")) 301 | (let ((full-uid (bic--find-message-at-point)) 302 | (mailbox bic--current-mailbox) 303 | (account bic--current-account)) 304 | (set-buffer gnus-original-article-buffer) 305 | (message-forward) 306 | (add-to-list 307 | 'message-send-actions 308 | (lambda () 309 | (fsm-send 310 | (bic--find-account account) 311 | (list :flags mailbox full-uid '("$Forwarded") ())))))) 312 | 313 | (defun bic--find-message-at-point () 314 | "Find UID of message at point. 315 | Assert that `bic--current-account' and `bic--current-mailbox' are set. 316 | Return the uidvalidity+uid value of the message under point. 317 | If no message found, signal a `user-error'." 318 | (unless (and bic--current-account bic--current-mailbox) 319 | (user-error "Not in mailbox or message buffer")) 320 | (cond 321 | ((local-variable-p 'bic-message--full-uid) 322 | bic-message--full-uid) 323 | ((local-variable-p 'bic-mailbox--ewoc) 324 | (pcase (ewoc-locate bic-mailbox--ewoc (point)) 325 | (`nil 326 | (user-error "No message under point")) 327 | (node 328 | (ewoc-data node)))) 329 | (t 330 | (user-error "Cannot locate message")))) 331 | 332 | (provide 'bic-message) 333 | ;;; bic-message.el ends here 334 | -------------------------------------------------------------------------------- /bic-org.el: -------------------------------------------------------------------------------- 1 | ;;; bic-org.el --- link to BIC messages from org-mode -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2015 Magnus Henoch 4 | 5 | ;; Author: Magnus Henoch 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Functions for storing and following links to email messages in 23 | ;; org-mode. There should be no need to call the functions in this 24 | ;; file directly; `org-store-link' should pick up the correct link 25 | ;; when invoked from a message or mailbox buffer, and 26 | ;; `org-open-at-point' should handle BIC links. 27 | 28 | ;;; Code: 29 | 30 | (require 'bic) 31 | 32 | ;;;###autoload 33 | (defun bic-org-store-link () 34 | "Store a link to an email. 35 | This function is called by `org-store-link'." 36 | (let ((full-uid 37 | (cond 38 | ((derived-mode-p 'bic-message-mode) 39 | bic-message--full-uid) 40 | ((derived-mode-p 'bic-mailbox-mode) 41 | ;; In a mailbox buffer, create a link to the message under point. 42 | (ewoc-data (ewoc-locate bic-mailbox--ewoc (point))))))) 43 | (when full-uid 44 | (let* ((link (concat "bic:" 45 | (bic--sanitize-mailbox-name bic--current-account) 46 | ":" 47 | (bic--sanitize-mailbox-name bic--current-mailbox) 48 | ":" 49 | full-uid)) 50 | (mailbox-buffer (bic-mailbox--find-buffer 51 | bic--current-account bic--current-mailbox)) 52 | (hashtable (when mailbox-buffer 53 | (buffer-local-value 'bic-mailbox--hashtable mailbox-buffer))) 54 | (envelope (when hashtable 55 | (gethash full-uid hashtable)))) 56 | (pcase envelope 57 | (`(,date ,subject ,from ,_sender ,_reply-to ,to ,_cc ,_bcc ,_in-reply-to ,message-id) 58 | (org-store-link-props 59 | :type "bic" 60 | :link link 61 | :date date 62 | :subject subject 63 | :message-id message-id 64 | :from (pcase from 65 | (`((,name ,_source-route ,mailbox-name ,host-name) . ,_) 66 | (mail-header-make-address name (concat mailbox-name "@" host-name)))) 67 | :to (pcase to 68 | (`((,name ,_source-route ,mailbox-name ,host-name) . ,_) 69 | (mail-header-make-address name (concat mailbox-name "@" host-name))))) 70 | (org-add-link-props :description (org-email-link-description)) 71 | link)))))) 72 | 73 | ;;;###autoload 74 | (defun bic-org-follow (link) 75 | "Open the email pointed to by LINK. 76 | This function is called by `org-open-at-point'." 77 | (unless (string-match "\\`\\([^:]+\\):\\([^:]+\\):\\([0-9-]+\\)\\'" link) 78 | (error "Invalid BIC link %S" link)) 79 | (let ((account (match-string 1 link)) 80 | (mailbox (match-string 2 link)) 81 | (full-uid (match-string 3 link))) 82 | (setq account (bic--unsanitize-mailbox-name account)) 83 | (setq mailbox (bic--unsanitize-mailbox-name mailbox)) 84 | (bic-message-display account mailbox full-uid))) 85 | 86 | ;;;###autoload 87 | (with-eval-after-load "org" 88 | ;; `org-link-set-parameters' is new in Org 9.0 89 | (if (fboundp 'org-link-set-parameters) 90 | (org-link-set-parameters 91 | "bic" 92 | :follow 'bic-org-follow 93 | :store 'bic-org-store-link) 94 | (org-add-link-type "bic" 'bic-org-follow) 95 | (add-to-list 'org-store-link-functions 'bic-org-store-link))) 96 | 97 | (provide 'bic-org) 98 | ;;; bic-org.el ends here 99 | -------------------------------------------------------------------------------- /bic-smtpmail.el: -------------------------------------------------------------------------------- 1 | ;;; bic-smtpmail.el --- toggle smtpmail offline status based on BIC -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2015 Magnus Henoch 4 | 5 | ;; Author: Magnus Henoch 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; `smtpmail' has a feature to queue messages that the user attempts 23 | ;; to send, and to send queued messages later. However, you have to 24 | ;; set `smtpmail-queue-mail' and run `smtpmail-send-queued-mail' 25 | ;; manually. This file does that for you, under the assumption that 26 | ;; when BIC has a connection to an IMAP server, you should be able to 27 | ;; send messages through SMTP, and vice versa. 28 | ;; 29 | ;; To use this feature, set `bic-smtpmail-toggle-queueing' to t. 30 | 31 | ;;; Code: 32 | 33 | (require 'bic) 34 | (require 'smtpmail) 35 | 36 | (defcustom bic-smtpmail-toggle-queueing nil 37 | "If non-nil, toggle `smtpmail-queue-mail' based on BIC status. 38 | If BIC is connected to at least one server that isn't localhost, 39 | turn queueing off and send any queued messages. 40 | Otherwise, turn queueing on, such that messages \"sent\" will 41 | be queued, in order to be sent when you're online again." 42 | :group 'bic 43 | :type 'boolean) 44 | 45 | (defun bic-smtpmail--online-p () 46 | "Are we online enough that we should try to send mail? 47 | Check whether at least one account whose server is not 48 | \"localhost\" is online." 49 | (let ((onlinep nil)) 50 | (maphash 51 | (lambda (account state) 52 | (when (eq state :connected) 53 | (unless (string= "localhost" 54 | (plist-get 55 | (fsm-get-state-data (bic--find-account account)) 56 | :server)) 57 | (setq onlinep t)))) 58 | bic-account-state-table) 59 | onlinep)) 60 | 61 | ;;;###autoload 62 | (defun bic-smtpmail--state-update (&optional _account _new-state) 63 | "Update smtpmail state when going online/offline. 64 | If going offline, start queuing outgoing messages. 65 | If going online, send queued messages. 66 | 67 | This function is meant to be added to 68 | `bic-account-state-update-functions'." 69 | (when bic-smtpmail-toggle-queueing 70 | (pcase (cons smtpmail-queue-mail (bic-smtpmail--online-p)) 71 | (`(nil . nil) 72 | ;; Went offline 73 | (setq smtpmail-queue-mail t) 74 | :went-offline) 75 | (`(t . t) 76 | ;; Went online 77 | (setq smtpmail-queue-mail nil) 78 | ;; XXX: what if sending fails? If so, need to reset `smtpmail-queue-mail'... 79 | ;; Perhaps display errors as warnings, to get attention? 80 | (run-with-idle-timer 10 nil 'smtpmail-send-queued-mail)) 81 | (`(nil . t) 82 | :still-online) 83 | (`(t . nil) 84 | :still-offline) 85 | (other 86 | (warn "Unknown state %S" other))))) 87 | 88 | ;;;###autoload 89 | (with-eval-after-load "bic" 90 | (add-hook 'bic-account-state-update-functions 'bic-smtpmail--state-update)) 91 | 92 | (provide 'bic-smtpmail) 93 | ;;; bic-smtpmail.el ends here 94 | --------------------------------------------------------------------------------