diff --git a/toys/mm/mm-common.el b/toys/mm/mm-common.el new file mode 100644 index 00000000..d17c1604 --- /dev/null +++ b/toys/mm/mm-common.el @@ -0,0 +1,413 @@ +;;; mm-common.el -- part of mm, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'ido) + + +(defun mm/eval-msg-string (str) + "Get the plist describing an email message, from STR containing +a message sexp. + + a message sexp looks something like: + \( + :from ((\"Donald Duck\" . \"donald@example.com\")) + :to ((\"Mickey Mouse\" . \"mickey@example.com\")) + :subject \"Wicked stuff\" + :date (20023 26572 0) + :size 15165 + :references (\"200208121222.g7CCMdb80690@msg.id\") + :in-reply-to \"200208121222.g7CCMdb80690@msg.id\" + :message-id \"foobar32423847ef23@pluto.net\" + :maildir: \"/archive\" + :path \"/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2,\" + :priority high + :flags (new unread) + :attachments ((2 \"hello.jpg\" \"image/jpeg\") (3 \"laah.mp3\" \"audio/mp3\")) + :body-txt \" \" +\) +other fields are :cc, :bcc, :body-html + +When the s-expression comes from the database ('mu find'), the +fields :attachments, :body-txt, :body-html, :references, :in-reply-to +are missing (because that information is not stored in the +database -- at least not in a usable way." + (condition-case nil + (car (read-from-string str));; read-from-string returns a cons + (error "Failed to parse message"))) + + +(defun mm/msg-field (msg field) + "Get a field from this message, or nil. The fields are the +fields of the message, which are the various items of the plist +as described in `mm/eval-msg-string' + +There is also the special field :body (which is either :body-txt, +or if not available, :body-html converted to text)." + (case field + (:body + (let* ((body (mm/msg-field msg :body-txt)) + (body (or body (with-temp-buffer + (mm/msg-field msg :body-html) + (html2text) + (buffer-string))))))) + (t (plist-get msg field)))) + + + + + + +;;; converting flags->string and vice-versa ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun mm/flags-to-string (flags) + "Remove duplicates and sort the output of `mm/flags-to-string-raw'." + (concat + (sort (remove-duplicates (append (mm/flags-to-string-raw flags) nil)) '>))) + +(defun mm/flags-to-string-raw (flags) + "Convert a list of flags into a string as seen in Maildir +message files; flags are symbols draft, flagged, new, passed, +replied, seen, trashed and the string is the concatenation of the +uppercased first letters of these flags, as per [1]. Other flags +than the ones listed here are ignored. + +Also see `mm/flags-to-string'. + +\[1\]: http://cr.yp.to/proto/maildir.html" + (when flags + (let ((kar (case (car flags) + ('draft ?D) + ('flagged ?F) + ('new ?N) + ('passed ?P) + ('replied ?R) + ('seen ?S) + ('trashed ?T) + ('encrypted ?x) + ('signed ?s) + ('unread ?u)))) + (concat (and kar (string kar)) + (mm/flags-to-string-raw (cdr flags)))))) + + +(defun mm/string-to-flags (str) + "Remove duplicates from the output of `mm/string-to-flags-1'" + (remove-duplicates (mm/string-to-flags-1 str))) + +(defun mm/string-to-flags-1 (str) + "Convert a string with message flags as seen in Maildir +messages into a list of flags in; flags are symbols draft, +flagged, new, passed, replied, seen, trashed and the string is +the concatenation of the uppercased first letters of these flags, +as per [1]. Other letters than the ones listed here are ignored. +Also see `mu/flags-to-string'. + +\[1\]: http://cr.yp.to/proto/maildir.html" + (when (/= 0 (length str)) + (let ((flag + (case (string-to-char str) + (?D 'draft) + (?F 'flagged) + (?P 'passed) + (?R 'replied) + (?S 'seen) + (?T 'trashed)))) + (append (when flag (list flag)) + (mm/string-to-flags-1 (substring str 1)))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + +;;; moving message files, changing flags ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun mm/move-msg (uid &optional targetdir flags ignore-already) + "Move message identified by UID to TARGETDIR using 'mu mv', and +update the database with the new situation. TARGETDIR must be a +maildir - that is, the part _without_ cur/ or new/. 'mu mv' will +calculate the target directory and the exact file name. See +`mm/msg-map' for a discussion about UID. + +After the file system move (rename) has been done, 'mu remove' +and/or 'mu add' are invoked asynchronously to update the database +with the changes. + +Optionally, you can specify the FLAGS for the new file. The FLAGS +parameter can have the following forms: + 1. a list of flags such as '(passed replied seen) + 2. a string containing the one-char versions of the flags, e.g. \"PRS\" + 3. a delta-string specifying the changes with +/- and the one-char flags, + e.g. \"+S-N\" to set Seen and remove New. + +The flags are any of `deleted', `flagged', `new', `passed', `replied' `seen' or +`trashed', or the corresponding \"DFNPRST\" as defined in [1]. See +`mm/string-to-flags' and `mm/flags-to-string'. + +If TARGETDIR is '/dev/null', remove SRC. After the file system +move, the database will be updated as well, using the 'mu add' +and 'mu remove' commands. + +If IGNORE-ALREADY is non-nil, don't consider it an error when the target file is +the same as the source file. + +Function returns t the move succeeds, in other cases, it returns +nil. + +\[1\] URL `http://cr.yp.to/proto/maildir.html'." + (let* ((src (mm/msg-map-get-path uid))) + (unless src (error "Source path not registered for %S" uid)) + (unless (or targetdir src) (error "Either targetdir or flags required")) + (unless (file-readable-p src) (error "Source is unreadable (%S)" src)) + (let* ((flagstr (if (stringp flags) flags (mm/flags-to-string flags))) + (argl (remove-if 'not ;; build up the arg list + (list "mv" "--print-target" "--ignore-dups" + (when flagstr (concat "--flags=" flagstr)) + src targetdir))) + ;; execute it, and get the results + (rv (apply 'mm/mu-run argl)) + (code (car rv)) (output (cdr rv))) + (unless (= 0 code) (error "Moving message failed: %S" output)) + ;; success! + (let ((targetpath (substring output 0 -1))) + (when (and targetpath (not (string= src targetpath))) + (mm/msg-map-update uid targetpath) ;; update the UID-map + (mm/db-remove-async src) ;; remove the src from the db + (unless (string= targetdir "/dev/null") + (mm/db-add-async targetpath))) ;; add the target to the db + (mm/db-update-execute) + t)))) + +;;; some functions for *asyncronously* updating the database + +(defvar mm/db-update-proc nil + "*internal* Process for async db updates.") +(defvar mm/db-update-name "*mm-db-update*" + "*internal* name of the db-update process") +(defvar mm/db-add-paths nil + "*internal* List of message paths to add to the database.") +(defvar mm/db-remove-paths nil + "*internal* List of message paths to remove from the database.") + + +(defun mm/db-update-proc-sentinel (proc msg) + "Check the database update process upon completion." + (let ((procbuf (process-buffer proc)) + (status (process-status proc)) + (exit-status (process-exit-status proc))) + (when (and (buffer-live-p procbuf) (memq status '(exit signal))) + (case status + ('signal (mm/log "Process killed")) + ('exit + (case exit-status + (mm/log "Result: %s" (mm/error-string exit-status)))))) + ;; try to update again, maybe there are some new updates + (mm/db-update-execute))) + + +(defun mm/db-update-execute () + "Update the database; remove paths in `mm/db-remove-paths', +and add paths in `mm/db-add-paths'. Updating is ansynchronous." + + ;; when it's already running, do nothing + (unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run)) + (when mm/db-remove-paths + (let ((remove-paths (copy-list mm/db-remove-paths))) + (mm/log (concat mm/mu-binary " remove " + (mapconcat 'identity remove-paths " "))) + (setq mm/db-remove-paths nil) ;; clear the old list + (setq mm/db-update-proc + (apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary + "remove" remove-paths)) + (set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel))))) + + ;; when it's already running, do nothing + (unless (and mm/db-update-proc (eq (process-status mm/db-update-proc) 'run)) + (when mm/db-add-paths + (let ((add-paths (copy-list mm/db-add-paths))) + (mm/log (concat mm/mu-binary " add " (mapconcat 'identity add-paths " "))) + (setq mm/db-add-paths nil) ;; clear the old list + (setq mm/db-update-proc + (apply 'start-process mm/db-update-name mm/db-update-name mm/mu-binary + "add" add-paths)) + (set-process-sentinel mm/db-update-proc 'mm/db-update-proc-sentinel)))) + +(defun mm/db-add-async (path-or-paths) + "Asynchronously add msg at PATH-OR-PATHS to +database. PATH-OR-PATHS is either a single path or a list of them." + (setq mm/db-add-paths + (append mm/db-add-paths + (if (listp path-or-paths) path-or-paths `(,path-or-paths))))) +;; (mm/db-update-execute)) + +(defun mm/db-remove-async (path-or-paths) + "Asynchronously remove msg at PATH-OR-PATHS from +database. PATH-OR-PATHS is either a single path or a list of +them." + (setq mm/db-remove-paths + (append mm/db-remove-paths + (if (listp path-or-paths) path-or-paths `(,path-or-paths))))) +;; (mm/db-update-execute)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + + + + +;;; error codes / names ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; generated with: +;; cat mu-util.h | sed 's/\([A-Z_]\+\).*=\(.*\),/(defconst \L\1 \2)/' < "$<" \ +;; | sed 's/_/-/g' > mu-errors.el +(defconst mm/err 1) +(defconst mm/err-in-parameters 2) +(defconst mm/err-internal 3) +(defconst mm/err-no-matches 4) +(defconst mm/err-xapian 11) +(defconst mm/err-xapian-query 13) +(defconst mm/err-xapian-dir-not-accessible 14) +(defconst mm/err-xapian-not-up-to-date 15) +(defconst mm/err-xapian-missing-data 16) +(defconst mm/err-xapian-corruption 17) +(defconst mm/err-xapian-cannot-get-writelock 18) +(defconst mm/err-gmime 30) +(defconst mm/err-contacts 50) +(defconst mm/err-contacts-cannot-retrieve 51) +(defconst mm/err-file 70) +(defconst mm/err-file-invalid-name 71) +(defconst mm/err-file-cannot-link 72) +(defconst mm/err-file-cannot-open 73) +(defconst mm/err-file-cannot-read 74) +(defconst mm/err-file-cannot-create 75) +(defconst mm/err-file-cannot-mkdir 76) +(defconst mm/err-file-stat-failed 77) +(defconst mm/err-file-readdir-failed 78) +(defconst mm/err-file-invalid-source 79) +(defconst mm/err-file-target-equals-source 80) + +;; TODO: use 'case' instead... +(defun mm/error-string (err) + "Convert an exit code from mu into a string." + (cond + ((eql err mm/err) "General error") + ((eql err mm/err-in-parameters) "Error in parameters") + ((eql err mm/err-internal) "Internal error") + ((eql err mm/err-no-matches) "No matches") + ((eql err mm/err-xapian) "Xapian error") + ((eql err mm/err-xapian-query) "Error in query") + ((eql err mm/err-xapian-dir-not-accessible) "Database dir not accessible") + ((eql err mm/err-xapian-not-up-to-date) "Database is not up-to-date") + ((eql err mm/err-xapian-missing-data) "Missing data") + ((eql err mm/err-xapian-corruption) "Database seems to be corrupted") + ((eql err mm/err-xapian-cannot-get-writelock)"Database is locked") + ((eql err mm/err-gmime) "GMime-related error") + ((eql err mm/err-contacts) "Contacts-related error") + ((eql err mm/err-contacts-cannot-retrieve) "Failed to retrieve contacts") + ((eql err mm/err-file) "File error") + ((eql err mm/err-file-invalid-name) "Invalid file name") + ((eql err mm/err-file-cannot-link) "Failed to link file") + ((eql err mm/err-file-cannot-open) "Cannot open file") + ((eql err mm/err-file-cannot-read) "Cannot read file") + ((eql err mm/err-file-cannot-create) "Cannot create file") + ((eql err mm/err-file-cannot-mkdir) "mu-mkdir failed") + ((eql err mm/err-file-stat-failed) "stat(2) failed") + ((eql err mm/err-file-readdir-failed) "readdir failed") + ((eql err mm/err-file-invalid-source) "Invalid source file") + ((eql err mm/err-file-target-equals-source) "Source is same as target") + (t (format "Unknown error (%d)" err)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + + +;;; other helper function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun mm/mu-run (&rest args) + "Run 'mu' synchronously with ARGS as command-line argument;, +where is the exit code of the program, or 1 if the +process was killed. contains whatever the command wrote on +standard output/error, or nil if there was none or in case of +error. `mm/mu-run' is like `shell-command-to-string', but with +better possibilities for error handling. The --muhome= parameter is +added automatically if `mm/mu-home' is non-nil." + (let* ((rv) + (allargs (remove-if 'not + (append args (when mm/mu-home (concat "--muhome=" mm/mu-home))))) + (cmdstr (concat mm/mu-binary " " (mapconcat 'identity allargs " "))) + (str (with-output-to-string + (with-current-buffer standard-output ;; but we also get stderr... + (setq rv (apply 'call-process mm/mu-binary nil t nil + args)))))) + (mm/log "%s %s => %S" mm/mu-binary (mapconcat 'identity args " ") rv) + (when (and (numberp rv) (/= 0 rv)) + (error (mm/error-string rv))) + `(,(if (numberp rv) rv 1) . ,str))) + + +(defun mm/ask-maildir (prompt &optional fullpath) + "Ask user with PROMPT for a maildir name, if fullpath is +non-nill, return the fulpath (i.e., `mm/maildir' prepended to the +chosen folder)." + (unless (and mm/inbox-folder mm/drafts-folder mm/sent-folder) + (error "`mm/inbox-folder', `mm/drafts-folder' and + `mm/sent-folder' must be set")) + (unless mm/maildir (error "`mm/maildir' must be set")) + (interactive) + (let* ((showfolders + (append (list mm/inbox-folder mm/drafts-folder mm/sent-folder) + mm/working-folders)) + (chosen (ido-completing-read prompt showfolders))) + (concat (if fullpath mm/maildir "") chosen))) + + +(defun mm/new-buffer (bufname) + "Return a new buffer BUFNAME; if such already exists, kill the +old one first." + (when (get-buffer bufname) + (progn + (message (format "Killing %s" bufname)) + (kill-buffer bufname))) + (get-buffer-create bufname)) + + +(defconst mm/log-buffer-name "*mm-log*" + "*internal* Name of the logging buffer.") + +(defun mm/log (frm &rest args) + "Write something in the *mm-log* buffer - mainly useful for debugging." + (with-current-buffer (get-buffer-create mm/log-buffer-name) + (goto-char (point-max)) + (insert (apply 'format (concat (format-time-string "%x %X " (current-time)) + frm "\n") args)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(provide 'mm-common) diff --git a/toys/mm/mm-hdrs.el b/toys/mm/mm-hdrs.el new file mode 100644 index 00000000..1b945542 --- /dev/null +++ b/toys/mm/mm-hdrs.el @@ -0,0 +1,493 @@ +;; mm-hdrs.el -- part of mm, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; In this file are function related to creating the list of one-line +;; descriptions of emails, aka 'headers' (not to be confused with headers like +;; 'To:' or 'Subject:') + +;; mu + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'mm-common) +(require 'mm-proc) + +(defvar mm/header-fields + '( (:date . 25) + (:from-or-to . 22) + (:subject . 40)) + "A list of header fields and their character widths.") + + +;;;; internal variables/constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar mm/last-expr nil + "*internal* The most recent search expression.") +(defvar mm/sortfield nil + "*internal* Field to sort headers by") +(defvar mm/sort-descending nil + "*internal Whether to sort in descending order") + + +(defconst mm/hdrs-buffer-name "*headers*" + "*internal* Name of the buffer for message headers.") + +(defvar mm/hdrs-buffer nil + "*internal* Buffer for message headers") + +(defun mm/hdrs-search (expr) + "Search in the mu database for EXPR, and switch to the output +buffer for the results." + (interactive "s[mu] search for: ") + ;; make sure we get a brand new buffer + (setq mm/hdrs-buffer (mm/new-buffer mm/hdrs-buffer-name)) + (switch-to-buffer mm/hdrs-buffer) + (mm/hdrs-mode) + (setq mm/last-expr expr) + (mm/msg-map-init) + (let ((inhibit-read-only t)) (erase-buffer)) ;; FIXME -- why is this needed?! + + ;; all set -- now execute the search + (mm/proc-find expr)) + +(defun mm/hdrs-message-handler (msg) + (message "Received message %d (%s)" + (plist-get msg :docid) + (plist-get msg :subject))) + +(defun mm/hdrs-error-handler (err) + (message "Error %d: %s" + (plist-get err :error) + (plist-get err :error-message))) + +(defun mm/hdrs-update-handler (update) + "Update handler, will be called when we get '(:update ... )' from +the mu server process. This function will update the current list +of headers." + (message "We received a database update: %S" update) + (let* ((type (plist-get update :update)) (docid (plist-get update :docid)) + (marker (mm/msg-map-get-marker docid))) + (unless docid (error "Invalid update %S" update)) + (unless marker (error "Message %d not found" docid)) + (with-current-buffer mm/hdrs-buffer + (save-excursion + (goto-char (marker-position marker)) + ;; sanity check + (unless (eq docid (get-text-property (point) 'docid)) + (error "Unexpected docid")) + (mm/hdrs-mark 'unmark) + (let ((inhibit-read-only t) (bol (line-beginning-position)) + (eol (line-beginning-position 2))) + (case type + (remove (put-text-property bol eol 'invisible t)) + (move (put-text-property bol eol 'face 'mm/moved-face)) + (t (error "Invalid update %S" update)))))))) + + +(defun mm/hdrs-header-handler (msg) + "Function to insert a line for a message. This will be called by +`mm/proc-find'. Function expects to be in the output buffer +already." + (let* ((docid (mm/msg-field msg :docid)) + (line (propertize (concat " " (mm/hdrs-line msg) "\n") + 'docid docid))) + ;; add message to the docid=>path map, see `mm/msg-map'. + (with-current-buffer mm/hdrs-buffer + (save-excursion + (goto-char (point-max)) + (mm/msg-map-add msg (point-marker)) + (let ((inhibit-read-only t)) + (insert line)))))) + +(defun mm/hdrs-line (msg) + "Get the one-line description of MSG (as per `mm/hdrs-raw-line'), and +apply text-properties based on the message flags." + (let ((line (mm/hdrs-raw-line msg)) + (flags (plist-get msg :flags))) + (cond + ((member 'unread flags) (propertize line 'face 'mm/unread-face)) + (t (propertize line 'face 'mm/header-face))))) + +(defun mm/hdrs-raw-line (msg) + "Create a one line description of MSG in this buffer at +point. Line does not include a newline or any text-properties." + (mapconcat + (lambda (f-w) + (let* ((field (car f-w)) (width (cdr f-w)) + (val (plist-get msg field)) + (str + (case field + (:subject val) + ((:to :from :cc :bcc) + (mapconcat + (lambda (ct) + (let ((name (car ct)) (email (cdr ct))) + (or name email "?"))) val ", ")) + (:date (format-time-string "%x %X" val)) + (:flags (mm/flags-to-string val)) + (:size + (cond + ((>= val 1000000) (format "%2.1fM" (/ val 1000000.0))) + ((and (>= val 1000) (< val 1000000)) + (format "%2.1fK" (/ val 1000.0))) + ((< val 1000) (format "%d" val)))) + (t (error "Unsupported header field (%S)" field))))) + (when str (truncate-string-to-width str width 0 ?\s t)))) + mm/header-fields " ")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + + + +;;; hdrs-mode and mode-map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar mm/hdrs-mode-map + (let ((map (make-sparse-keymap))) + + (define-key map "s" 'mm/search) + (define-key map "q" 'mm/quit-buffer) + (define-key map "o" 'mm/change-sort) + (define-key map "g" 'mm/rerun-search) + + ;; navigation + (define-key map "n" 'mm/next-header) + (define-key map "p" 'mm/prev-header) + (define-key map "j" 'mm/jump-to-maildir) + + ;; marking/unmarking/executing + (define-key map "m" 'mm/mark-for-move) + (define-key map "d" 'mm/mark-for-trash) + (define-key map "D" 'mm/mark-for-delete) + (define-key map "u" 'mm/unmark) + (define-key map "U" 'mm/unmark-all) + (define-key map "x" 'mm/execute-marks) + + ;; message composition + ;; (define-key map "r" 'mua/hdrs-reply) + ;; (define-key map "f" 'mua/hdrs-forward) + ;; (define-key map "c" 'mua/hdrs-compose) + + (define-key map (kbd "RET") 'mm/view-message) + map) + "Keymap for *mm-headers* buffers.") +(fset 'mm/hdrs-mode-map mm/hdrs-mode-map) + +(defun mm/hdrs-mode () + "Major mode for displaying mua search results." + (interactive) + + (kill-all-local-variables) + (use-local-map mm/hdrs-mode-map) + + (make-local-variable 'mm/buf) + (make-local-variable 'mm/last-expr) + (make-local-variable 'mm/hdrs-proc) + (make-local-variable 'mm/marks-map) + (make-local-variable 'mm/msg-map) + + ;; we register our handler functions for the mm-proc (mu server) output + (setq mm/proc-error-func 'mm/hdrs-error-handler) + (setq mm/proc-update-func 'mm/hdrs-update-handler) + (setq mm/proc-header-func 'mm/hdrs-header-handler) + (setq mm/proc-message-func 'mm/hdrs-message-handler) + + (setq + mm/marks-map (make-hash-table :size 16 :rehash-size 2) + major-mode 'mm/hdrs-mode + mode-name "*mm-headers*" + truncate-lines t + buffer-read-only t + overwrite-mode 'overwrite-mode-binary)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; the message map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar mm/msg-map nil + "*internal* A map (hashtable) which maps a database (Xapian) +docid (which uniquely identifies a message to a marker. where +marker points to the buffer position for the message. + +Using this map, we can update message headers which are currently +on the screen, when we receive (:update ) notices from the mu +server.") + +(defun mm/msg-map-add (msg marker) + "Update `mm/msg-map' with MSG, and MARKER pointing to the buffer + position for the message header." + (let ((docid (plist-get msg :docid))) + (unless docid (error "Invalid message")) + (puthash docid marker mm/msg-map))) + +(defun mm/msg-map-get-marker (docid) + "Get the marker for the message identified by DOCID." + (gethash docid mm/msg-map)) + +(defun mm/msg-map-init() + "(Re)initialize the msg map for use -- re-create the hash table, +and reset the last-uid to 0." + (setq mm/msg-map + (make-hash-table :size 256 :rehash-size 2 :weakness nil))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + +;;; marks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar mm/marks-map nil + "Map (hash) of docid->markinfo; when a message is marked, the +information is added here. + +markinfo is a list consisting of the following: +\(marker mark target) +where + MARKER is an emacs-textmarker pointing to the beginning of the header line + MARK is the type of mark (move, trash, delete) + TARGET (optional) is the target directory (for 'move')") + +(defun mm/hdrs-mark (mark &optional target) + "Mark (or unmark) header line at point. MARK specifies the + mark-type. For `move'-marks there is also the TARGET argument, + which specifies to which maildir the message is to be moved. + +The following marks are available, and the corresponding props: + + MARK TARGET description + ---------------------------------------------------------- + `move' y move the message to some folder + `trash' n move the message to `mm/trash-folder' + `delete' n remove the message + `unmark' n unmark this message" + (let* ((docid (get-text-property (point) 'docid)) + (markkar + (case mark ;; the visual mark + ('move "m") + ('trash "d") + ('delete "D") + ('unmark " ") + (t (error "Invalid mark %S" mark))))) + (unless docid (error "No message on this line")) + (save-excursion + (move-beginning-of-line 1) + + ;; is there anything to mark/unmark? + (when (and (looking-at " ") (eql mark 'unmark)) + (error "Not marked")) + (when (not (or (looking-at " ") (eql mark 'unmark))) + (error "Already marked")) + + ;; update the hash + (if (eql mark 'unmark) + (remhash docid mm/marks-map) + (puthash docid (list (point-marker) mark target) mm/marks-map)) + + ;; now, update the visual mark..; + (let ((inhibit-read-only t)) + (delete-char 2) + (insert (propertize (concat markkar " ") 'docid docid)))))) + + + + +(defun mm/hdrs-marks-execute () + "Execute the actions for all marked messages in this +buffer. + +After the actions have been executed succesfully, the affected +messages are *hidden* from the current header list. Since the +headers are the result of a search, we cannot be certain that the +messages no longer matches the current one - to get that certainty, +we need to rerun the search, but we don't want to do that +automatically, as it may be too slow and/or break the users +flow. Therefore, we hide the message, which in practice seems to +work well." + (unless (/= 0 (hash-table-count mm/marks-map)) + (error "Nothing is marked")) + (maphash + (lambda (docid val) + (let* ((marker (nth 0 val)) (mark (nth 1 val)) (target (nth 2 val)) + (ok (case mark + (move + (mm/proc-move-msg docid target)) + (trash + (unless mm/maildir "`mm/maildir' not set") + (unless mm/trash-folder "`mm/trash-folder' not set") + (mm/proc-move-msg docid (concat mm/maildir "/" mm/trash-folder) "+T")) + (delete + (mm/proc-remove-msg docid))))) + ;; (when ok + ;; (save-excursion + ;; (goto-char (marker-position marker)) + ;; (mm/hdrs-mark 'unmark) + ;; ;; hide the line + ;; (let ((inhibit-read-only t)) + ;; (put-text-property (line-beginning-position) (line-beginning-position 2) + ;; 'invisible t)))))) + )) + mm/marks-map)) + + +(defun mm/hdrs-unmark-all () + "Unmark all marked messages." + (unless (/= 0 (hash-table-count mm/marks-map)) + (error "Nothing is marked")) + (maphash + (lambda (docid val) + (save-excursion + (goto-char (marker-position (nth 0 val))) + (mm/hdrs-mark 'unmark))) + mm/marks-map)) + +(defun mm/hdrs-view () + "View message at point" + (let ((docid (get-text-property (point) 'docid))) + (unless docid (error "No message at point.")) + (mm/proc-view-msg docid))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + +;;; interactive functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TODO warn if marks exist +(defun mm/search () + "Start a new mu search." + (interactive) + (call-interactively 'mm/hdrs-search)) + +;; TODO warn if marks exist +;; TODO: return to previous buffer +(defun mm/quit-buffer () + "Quit the current buffer." + (interactive) + (kill-buffer (current-buffer))) + +;; TODO implement +(defun mm/change-sort () + "Change the sorting field and/or direction." + (interactive) + ) + +;; TODO warn if marks exist +(defun mm/rerun-search () + "Rerun the search for the last search expression; if none exists, +do a new search." + (interactive) + (if mm/last-expr + (mm/hdrs-search mm/last-expr) + (mm/search))) + +(defun mm/view-message () + "View the message at point." + (interactive) + (mm/hdrs-view)) + +(defun mm/next-header () + "Move point to the next header." + (interactive) + (when (or (/= 0 (forward-line 1)) (not (get-text-property (point) 'docid))) + (error "No header after this one"))) + +(defun mm/prev-header () + "Move point to the previous header." + (interactive) + (when (or (/= 0 (forward-line -1)) (not (get-text-property (point) 'docid))) + (error "No header before this one"))) + +(defun mm/jump-to-maildir () + "Show the messages in one of the standard folders." + (interactive) + (let ((fld (mm/ask-maildir "Jump to maildir: "))) + (mm/hdrs-search (concat "maildir:" fld)))) + +(defun mm/mark-for-move () + "Mark message at point for moving to a maildir." + (interactive) + (let ((target (mm/ask-maildir "Target maildir for move: "))) + (when (or (file-directory-p target) + (and (yes-or-no-p + (format "%s does not exist. Create now?" target)) + (mm/proc-mkdir target))) + (mm/hdrs-mark 'move target) + (mm/next-header)))) + +(defun mm/mark-for-trash () + "Mark message at point for moving to the trash +folder (`mm/trash-folder')." + (interactive) + (unless mm/trash-folder (error "`mm/trash-folder' is not set")) + (mm/hdrs-mark 'trash) + (mm/next-header)) + +(defun mm/mark-for-delete () + "Mark message at point for direct deletion." + (interactive) + (mm/hdrs-mark 'delete) + (mm/next-header)) + +(defun mm/unmark () + "Unmark message at point." + (interactive) + (mm/hdrs-mark 'unmark) + (mm/next-header)) + +(defun mm/unmark-all () + "Unmark all messages." + (interactive) + (unless (/= 0 (hash-table-count mm/marks-map)) + (error "Nothing is marked")) + (when (y-or-n-p (format "Sure you want to unmark %d message(s)?" + (hash-table-count mm/marks-map))) + (mm/hdrs-unmark-all))) + +(defun mm/execute-marks () + "Execute the actions for the marked messages." + (interactive) + (unless (/= 0 (hash-table-count mm/marks-map)) + (error "Nothing is marked")) + (when (y-or-n-p (format "Sure you want to execute marks on %d message(s)?" + (hash-table-count mm/marks-map))) + (mm/hdrs-marks-execute))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +(provide 'mm-hdrs) + diff --git a/toys/mm/mm-proc.el b/toys/mm/mm-proc.el new file mode 100644 index 00000000..707a40d0 --- /dev/null +++ b/toys/mm/mm-proc.el @@ -0,0 +1,256 @@ +;;; mm-proc.el -- part of mm, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: +(eval-when-compile (require 'cl)) + +(require 'mm-common) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; internal vars + +(defvar mm/mu-proc nil + "*internal* The mu-server process") + +(defvar mm/proc-header-func nil + "*internal* A function called for each message returned from the +server process; the function is passed a msg plist as argument. See +`mm/proc-eval-server-output' for the format.") + +(defvar mm/proc-error-func nil + "*internal* A function called for each error returned from the +server process; the function is passed an error plist as +argument. See `mm/proc-eval-server-output' for the format.") + +(defvar mm/proc-update-func nil + "*internal* A function called for each update sexp returned from +the server process; the function is passed an update plist as +argument. See `mm/proc-eval-server-output' for the format.") + +(defvar mm/proc-message-func nil + "*internal* A function called for each message sexp returned from +the server process. This is designed for viewing a message. See +`mm/proc-eval-server-output' for the format.") + + +(defconst mm/eox-mark "\n;;eox\n" + "*internal* Marker for the end of a sexp") + +(defvar mm/buf "" + "*internal* Buffer for results data.") + +(defun mm/start-proc () + "Start the mu server process." + ;; TODO: add version check + (unless (file-executable-p mm/mu-binary) + (error (format "%S is not executable" mm/mu-binary))) + (let* ((process-connection-type nil) ;; use a pipe + (args '("server")) + (args (append args (when mm/mu-home + (list (concat "--muhome=" mm/mu-home)))))) + (setq mm/mu-proc (apply 'start-process "*mu-server*" "*mu-server*" + mm/mu-binary args)) + (when mm/mu-proc + (set-process-filter mm/mu-proc 'mm/proc-filter) + (set-process-sentinel mm/mu-proc 'mm/proc-sentinel)))) + +(defun mm/kill-proc () + "Kill the mu server process." + (when (mm/proc-is-running) + (let ((delete-exited-processes t)) + (kill-process mm/mu-proc) + (setq mm/mu-proc nil)))) + +(defun mm/proc-is-running () + (and mm/mu-proc (eq (process-status mm/mu-proc) 'run))) + + +(defun mm/proc-filter (proc str) + "A process-filter for the 'mu server' output; it accumulates the + strings into valid sexps by checking of the ';;eox' end-of-msg + marker, and then evaluating them." + (setq mm/buf (concat mm/buf str)) ;; update our buffer + (let ((eox (string-match mm/eox-mark mm/buf))) + (while eox + ;; Process the sexp in `mm/buf', and remove it if it worked and return + ;; t. If no complete sexp is found, return nil." + (let ( (after-eox (match-end 0)) + (sexp (mm/proc-eval-server-output (substring mm/buf 0 eox)))) + ;; the sexp we get can either be a message or an error + (message "[%S]" sexp) + (cond + ((plist-get sexp :error) (funcall mm/proc-error-func sexp)) + ;; if it has :docid, it's a message; if it's dbonly prop is `t', it's + ;; a header, otherwise it's a message (for viewing) + ((eq (plist-get sexp :msgtype) 'header) + (funcall mm/proc-header-func sexp)) + ((eq (plist-get sexp :msgtype) 'view) + (funcall mm/proc-message-func sexp)) + ((plist-get sexp :update) (funcall mm/proc-update-func sexp)) + (t (message "%S" sexp))) + ;;(t (error "Unexpected data from server")))) + (setq mm/buf (substring mm/buf after-eox))) + (setq eox (string-match mm/eox-mark mm/buf))))) + +(defun mm/proc-sentinel (proc msg) + "Function that will be called when the mu-server process +terminates." + (let ((status (process-status proc)) (code (process-exit-status proc))) + (setq mm/mu-proc nil) + (setq mm/buf "") ;; clear any half-received sexps + (cond + ((eq status 'signal) + (message (format "mu server process received signal %d" code))) + ((eq status 'exit) + (cond + ((eq code 11) (message "Database is locked by another process")) + (t (message (format "mu server process ended with exit code %d" code))))) + (t + (message "something bad happened to the mu server process"))))) + +(defun mm/proc-eval-server-output (str) + "Evaluate a blob of server output; the output describe either a +message, a database update or an error. + +An error sexp looks something like: + + (:error 2 :error-message \"unknown command\") +;; eox + +a message sexp looks something like: + + \( + :docid 1585 + :from ((\"Donald Duck\" . \"donald@example.com\")) + :to ((\"Mickey Mouse\" . \"mickey@example.com\")) + :subject \"Wicked stuff\" + :date (20023 26572 0) + :size 15165 + :references (\"200208121222.g7CCMdb80690@msg.id\") + :in-reply-to \"200208121222.g7CCMdb80690@msg.id\" + :message-id \"foobar32423847ef23@pluto.net\" + :maildir: \"/archive\" + :path \"/home/mickey/Maildir/inbox/cur/1312254065_3.32282.pluto,4cd5bd4e9:2,\" + :priority high + :flags (new unread) + :attachments ((2 \"hello.jpg\" \"image/jpeg\") (3 \"laah.mp3\" \"audio/mp3\")) + :body-txt \" \" +\) +;; eox + +a database update looks like: +\(:update 1585 :path \"/home/user/Maildir/foo/cur/12323213:,R\") + when a message has been moved to a new location, or +\(:update 1585 :path \"/dev/null\") + when it has been removed. + +other fields are :cc, :bcc, :body-html + +When the s-expression comes from the database ('mu find'), the +fields :attachments, :body-txt, :body-html, :references, :in-reply-to +are missing (because that information is not stored in the +database). + +On the other hand, if the information comes from the message file, +there won't be a :docid field." + (condition-case nil + (car (read-from-string str));; read-from-string returns a cons + (error "Failed to parse sexp [%S]" str))) + + +(defun mm/proc-remove-msg (docid) + "Remove message identified by DOCID. The results are reporter +through either (:update ... ) or (:error ) sexp, which are handled +my `mm/proc-update-func' and `mm/proc-error-func', respectively." + (unless (mm/proc-is-running) (mm/start-proc)) + (when mm/mu-proc + (process-send-string mm/mu-proc (format "remove %d\n" docid)))) + + +(defun mm/proc-find (expr) + "Start a database query for EXPR. For each result found, a +function is called, depending on the kind of result. The variables +`mm/proc-header-func' and `mm/proc-error-func' contain the function +that will be called for, resp., a message (header row) or an +error." + (unless (mm/proc-is-running) (mm/start-proc)) + (when mm/mu-proc + (process-send-string mm/mu-proc (format "find %s\n" expr)))) + + +(defun mm/proc-move-msg (docid targetdir flags) + "Move message identified by DOCID to TARGETDIR, setting FLAGS in +the process. + +TARGETDIR must be a maildir, that is, the part _without_ cur/ or +new/. + +The FLAGS parameter can have the following forms: + 1. a list of flags such as '(passed replied seen) + 2. a string containing the one-char versions of the flags, e.g. \"PRS\" + 3. a delta-string specifying the changes with +/- and the one-char flags, + e.g. \"+S-N\" to set Seen and remove New. + +The flags are any of `deleted', `flagged', `new', `passed', `replied' `seen' or +`trashed', or the corresponding \"DFNPRST\" as defined in [1]. See +`mm/string-to-flags' and `mm/flags-to-string'. + +The server reports the results for the operation through +`mm/proc-update-func'. + +The results are reported through either (:update ... ) +or (:error ) sexp, which are handled my `mm/proc-update-func' and +`mm/proc-error-func', respectively." + (let + ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))) + (unless (and (file-directory-p targetdir) (file-writable-p targetdir)) + (error "Not a writable directory: %s" targetdir)) + + (unless (mm/proc-is-running) (mm/start-proc)) + (when mm/mu-proc + (process-send-string mm/mu-proc + (format "move %d %s %s\n" docid targetdir flagstr))))) + + +(defun mm/proc-flag-msg (docid flags) + "Set FLAGS for the message identified by DOCID." + (let ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))) + (unless (mm/proc-is-running) (mm/start-proc)) + (when mm/mu-proc + (process-send-string mm/mu-proc + (format "flag %d %s\n" docid flagstr))))) + + +(defun mm/proc-view-msg (docid) + "Get one particular message based on its DOCID. The result will +be delivered to the function registered as `mm/proc-message-func'." + (unless (mm/proc-is-running) (mm/start-proc)) + (when mm/mu-proc + (process-send-string mm/mu-proc + (format "view %d\n" docid)))) + + +(provide 'mm-proc) diff --git a/toys/mm/mm.el b/toys/mm/mm.el new file mode 100644 index 00000000..c76557d6 --- /dev/null +++ b/toys/mm/mm.el @@ -0,0 +1,152 @@ +;;; mm.el -- part of mm, the mu mail user agent +;; +;; Copyright (C) 2011 Dirk-Jan C. Binnema + +;; Author: Dirk-Jan C. Binnema +;; Maintainer: Dirk-Jan C. Binnema +;; Keywords: email +;; Version: 0.0 + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(add-to-list 'load-path "/home/djcb/Sources/mu/toys/mm") + +(require 'mm-hdrs) +(require 'mm-common) +(require 'mm-proc) + +;; Customization + +(defgroup mm nil + "Mm." :group 'local) + + +(defcustom mm/mu-home nil + "Location of the mu homedir, or nil for the default." + :type 'directory + :group 'mm + :safe 'stringp) + +(defcustom mm/mu-binary "mu" + "Name of the mu-binary to use; if it cannot be found in your +PATH, you can specifiy the full path." + :type 'file + :group 'mm + :safe 'stringp) + +(defcustom mm/maildir nil + "Your Maildir directory. When `nil', mu will try to find it." + :type 'directory + :safe 'stringp + :group 'mm) + + +;; Folders + +(defgroup mm/folders nil + "Special folders for mm." + :group 'mm) + + +(defcustom mm/inbox-folder nil + "Your Inbox folder, relative to `mm/maildir'." + :type 'string + :safe 'stringp + :group 'mm/folders) + +(defcustom mm/outbox-folder nil + "Your Outbox folder, relative to `mm/maildir'." + :type 'string + :safe 'stringp + :group 'mm/folders) + +(defcustom mm/sent-folder nil + "Your folder for sent messages, relative to `mm/maildir'." + :type 'string + :safe 'stringp + :group 'mm/folders) + +(defcustom mm/draft-folder nil + "Your folder for draft messages, relative to `mm/maildir'." + :type 'string + :safe 'stringp + :group 'mm/folders) + +(defcustom mm/trash-folder nil + "Your folder for trashed messages, relative to `mm/maildir'." + :type 'string + :safe 'stringp + :group 'mm/folders) + +;; Faces + +(defgroup mm/faces nil + "Faces used in by mm." + :group 'mm + :group 'faces) + +(defface mm/unread-face + '((t :inherit font-lock-keyword-face :bold t)) + "Face for an unread mm message header." + :group 'mm/faces) + +(defface mm/moved-face + '((t :inherit font-lock-comment-face :italic t)) + "Face for an mm message header that has been moved from the +search results." + :group 'mm/faces) + +(defface mm/header-face + '((t :inherit default)) + "Face for an mm header without any special flags." + :group 'deft-faces) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FIXME +(setq + mm/maildir "/home/djcb/Maildir" + mm/inbox-folder "/inbox" + mm/outbox-folder "/outbox" + mm/sent-folder "/sent" + mm/drafts-folder "/drafts" + mm/trash-folder "/trash") + +(defvar mm/working-folders nil) + +(setq mm/working-folders + '("/bulk" "/archive" "/bulkarchive" "/todo")) + +(setq mm/header-fields + '( (:date . 25) + (:flags . 6) + (:from . 22) + (:subject . 40))) + +;;; my stuff +(setq mm/mu-binary "/home/djcb/Sources/mu/src/mu") +(setq mm/mu-home "/home/djcb/.mu") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(provide 'mm)