alx/mu4e
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* move emacs/ code to toys/mua; rename mu=>mua, many updates

Browse Source
This commit is contained in:
Dirk-Jan C. Binnema
2011-08-08 21:55:59 +03:00
parent 46c8e79fea
commit 74d00e26d4
11 changed files with 1306 additions and 1145 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
toys/mua/Makefile Normal file
View File

@ -0,0 +1,31 @@
VERSION=$(shell git describe --tags --dirty)
EMACS=emacs
PREFIX=/usr/local
ELS=mu.el mu-common.el mu-view.el mu-headers.el
ELCS=$(ELS:.el=.elc)
.PHONY=install
BATCH=$(EMACS) -batch -q -no-site-file -eval \
"(setq load-path (cons (expand-file-name \".\") load-path))"
%.elc: %.el
$(BATCH) --eval '(byte-compile-file "$<")'
all: $(ELCS)
docs: mu.infogg
install_lisp:
mkdir -p $(DESTDIR)/$(PREFIX)/share/emacs/site-lisp
install -m 644 $(ELS) $(ELCS) $(DESTDIR)/$(PREFIX)/share/emacs/site-lisp
install_docs: docs
mkdir -p $(DESTDIR)/$(PREFIX)/share/info
install -m 644 mu.info $(DESTDIR)/$(PREFIX)/share/info
install-info --info-dir=$(DESTDIR)/$(PREFIX)/share/info $(DESTDIR)/$(PREFIX)/share/info/mu.info
install: install_lisp install_docs
clean:
rm -fr mu.info $(ELCS)

28
toys/mua/TODO Normal file
View File

@ -0,0 +1,28 @@
* TODO
[ ] message un-new in find/view
[ ] set 'Replied' flag on source when message is replied
[ ] update database after changes (CHECK)
[ ] save message to draft, sent items
[ ] attachment handling (open, play) in view
[ ] abstract away mu/binary, shell-command-to-string
[ ] make flag handling a bit more lispy
[ ] threads support
[ ] expandable recipients list in view
[ ] additive font props in mu find
[ ] fix headers/view interaction
[ ] region commands
[ ] menu
[ ] mua-dashboard
# Local Variables:
# mode: org; org-startup-folded: nil
# End:

94
toys/mua/mua-common.el Normal file
View File

@ -0,0 +1,94 @@
;;; mua-common.el -- part of mua, the mu mail user agent
;;
;; Copyright (C) 2011 Dirk-Jan C. Binnema
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; mua-common contains common utility functions for mua
;;; Code:
(eval-when-compile (require 'cl))
(defconst mua/log-buffer-name "*mua-log*" "name of the logging buffer")
(defun mua/warn (frm &rest args)
"warn user in echo-area, return nil"
(let ((str (apply 'format frm args)))
(message str)
nil))
(defun mua/log (frm &rest args)
"write something in the *mua-log* buffer - mainly useful for debugging"
(with-current-buffer (get-buffer-create mua/log-buffer-name)
(goto-char (point-max))
(insert (apply 'format (concat (format-time-string "%x %X " (current-time))
frm "\n") args))))
(defun mua/warn-and-log (frm &rest args)
"log and warn (ie., mua/warn + mua/log); return nil"
(apply 'mua/log frm args)
(apply 'mua/warn frm args)
nil)
(defun mua/new-buffer (bufname)
"return a new buffer BUFNAME; if such already exists, kill the
old one first"
(when (get-buffer bufname)
(kill-buffer bufname))
(get-buffer-create bufname))
(defun mua/message (frm &rest args)
"print a mua message at point"
(let ((str (apply 'format frm args)) (inhibit-read-only t))
(insert (propertize str 'face 'italic))))
(defun mua/quit-buffer ()
"kill this buffer, and switch to it's parentbuf if it is alive"
(interactive)
(let ((parentbuf mua/parent-buffer))
(kill-buffer)
(when (and parentbuf (buffer-live-p parentbuf))
(switch-to-buffer parentbuf))))
(defun mua/ask-maildir (prompt &optional fullpath)
"ask user with PROMPT for a maildir name, if fullpath is
non-nill, return the fulpath (ie, mu-maildir prepended to the
maildir"
(interactive)
(let* ((showfolders
(delete-dups
(append (list mua/inbox-folder mua/sent-folder)
mua/working-folders)))
(chosen (ido-completing-read prompt showfolders)))
(concat (if fullpath mua/maildir "") chosen)))
(defun mua/mu-binary-version ()
"Get the version of the mu binary."
(let ((cmd (concat mua/mu-binary
" --version | head -1 | sed 's/.*version //'")))
(substring (shell-command-to-string cmd) 0 -1)))
(provide 'mua-common)

480
toys/mua/mua-hdrs.el Normal file
View File

@ -0,0 +1,480 @@
;;; mua-hdrs.el -- part of mua, the mu mail user agent
;;
;; Copyright (C) 2011 Dirk-Jan C. Binnema
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; mu
;;; Code:
(eval-when-compile (require 'cl))
(require 'mua-common)
(require 'mua-msg)
;; note: these next two are *not* buffer-local, so they persist during a session
(defvar mua/hdrs-sortfield nil "field to sort headers by")
(defvar mua/hdrs-sort-descending nil "whether to sort in descending order")
(defvar mua/header-fields
'( (:date . 25)
(:from-or-to . 22)
(:subject . 40))
"a list of fields and their widths")
;; internal stuff
(defvar mua/buf "" "buffer for results data")
(defvar mua/last-expression "the last search expression")
(defvar mua/hdrs-process "the mu-find process")
(defvar mua/hdrs-hash nil "the bol->path hash")
(defvar mua/hdrs-marks-hash nil "the hash for marked messages")
(defconst mua/eom "\n;;eom\n" "marker for the end of message in
the mu find output")
(defconst mua/hdrs-buffer-name "*mua-headers*"
"name of the mua headers buffer")
(defun mua/hdrs-proc-filter (proc str)
"process-filter for the 'mu find --format=sexp output; it
accumulates the strings into valid sexps by checking of the
';;eom' end-of-msg marker, and then evaluating them"
(let ((procbuf (process-buffer proc)))
(when (buffer-live-p procbuf)
(with-current-buffer procbuf
(save-excursion
(setq mua/buf (concat mua/buf str))
(let ((eom (string-match mua/eom mua/buf)))
(while (numberp eom)
(let* ((msg (mua/msg-from-string(substring mua/buf 0 eom))))
(save-match-data (mua/hdrs-append-message msg))
(setq mua/buf (substring mua/buf (match-end 0)))
(setq eom (string-match mua/eom mua/buf))))))))))
(defun mua/hdrs-proc-sentinel (proc msg)
"Check the 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)))
(let ((msg
(case status
('signal "Search process killed (results incomplete)")
('exit
(case exit-status
(0 "End of search results")
(1 "mu find error")
(2 "No matches found")
(4 "Database problem; try running 'mu index'")
(t (format "Some error occured; mu find returned %d"
exit-status)))))))
(with-current-buffer procbuf
(save-excursion
(goto-char (point-max))
(mua/message msg)))
(unless (= exit-status 0)
(mua/log "mu find exit with %d" exit-status))))))
(defun mua/hdrs-search-execute (expr buf)
"search in the mu database; output the results in buffer BUF"
(let ((args `("find" "--format=sexp" ,expr)))
(when mua/mu-home
(add-to-list args (concat "--muhome=" mua/mu-home)))
(when mua/hdrs-sortfield
(add-to-list args (concat "--sortfield=" mua/hdrs-sortfield)))
(when mua/hdrs-sort-descending
(add-to-list args "--descending"))
(mua/log "Searching for %s with %S" expr args)
;; now, do it!
(let ((proc (apply 'start-process "*mua-headers*" buf mua/mu-binary args)))
(setq
mua/buf ""
mua/hdrs-process proc)
(set-process-filter proc 'mua/hdrs-proc-filter)
(set-process-sentinel proc 'mua/hdrs-proc-sentinel))))
;; Note, the 'mu find --format=sexp' sexp is almost the same as the ones that
;; 'mu view --format=sexp' produces (see mu-get-message), with the difference
;; that former may give more than one result, and that mu-headers output comes
;; from the database rather than file, and does _not_ contain the message body
(defun mua/hdrs-search (expr)
"search in the mu database"
(interactive "s[mu] search for: ")
(setq debug-on-error t)
;; kill running process if needed
(when (and mua/hdrs-process
(eq (process-status mua/hdrs-process) 'run))
(kill-process mua/hdrs-process))
(let ((buf (mua/new-buffer mua/hdrs-buffer-name)))
(switch-to-buffer buf)
(mua/hdrs-mode)
(setq
mua/last-expression expr
mua/hdrs-hash (make-hash-table :size 256 :rehash-size 2)
mua/hdrs-marks-hash (make-hash-table :size 16 :rehash-size 2))
(mua/log "searching for %S" expr)
(mua/hdrs-search-execute expr buf)))
(defun mua/hdrs-mode ()
"major mode for displaying mua search results"
(interactive)
(kill-all-local-variables)
(use-local-map mua/hdrs-mode-map)
(make-local-variable 'mua/buf)
(make-local-variable 'mua/last-expression)
(make-local-variable 'mua/hdrs-process)
(make-local-variable 'mua/hdrs-hash)
(make-local-variable 'mua/hdrs-marks-hash)
(setq
major-mode 'mu-headers-mode mode-name "*headers*"
truncate-lines t buffer-read-only t
overwrite-mode 'overwrite-mode-binary))
(defun mua/hdrs-line (msg)
"return line describing a message (ie., a header line)"
(let
((hdr
(mapconcat
(lambda(fieldpair)
(let ((field (car fieldpair)) (width (cdr fieldpair)))
(case field
(:subject (mua/hdrs-header msg :subject width))
(:to (mua/hdrs-contact msg field width))
(:from (mua/hdrs-contact msg field width))
;;(:from-or-to (mua/msg-header-header-from-or-to msg width 'mua/header-face))
(:cc (mua/hdrs-contact msg field width))
(:bcc (mua/hdrs-contact msg field width))
(:date (mua/hdrs-date msg width))
(:flags (mua/hdrs-flags msg width))
(:size (mua/hdrs-size msg width))
(t (error "Unsupported field: %S" field))
)))
mua/header-fields " ")))
hdr))
;;
;; Note: we maintain a hash table to remember what message-path corresponds to a
;; certain line in the buffer. (mua/hdrs-set-path, mua/hdrs-get-path)
;;
;; data is stored like the following: for each header-line, we
;; take the (point) at beginning-of-line (bol) and use that as the key in the
;; mu-headers-hash hash, which does
;;
;; point-of-bol -> path
;;
(defun mua/hdrs-set-path (path)
"map the bol of the current header to a path"
(puthash (line-beginning-position 1) path mua/hdrs-hash))
(defun mua/hdrs-get-path ()
"get the path for the header at point"
(gethash (line-beginning-position 1) mua/hdrs-hash))
(defun mua/hdrs-append-message (msg)
"append a message line to the buffer and register the message"
(let ((line (mua/hdrs-line msg)) (inhibit-read-only t))
(save-excursion
(goto-char (point-max))
(mua/hdrs-set-path (mua/msg-field msg :path))
(insert " " line "\n"))))
;; Now follow a bunch of function to turn some message field in a
;; string for display
(defun mua/hdrs-header (msg field width)
"get a string at WIDTH (truncate or ' '-pad) for display as a
header"
(let* ((str (mua/msg-field msg field)) (str (if str str "")))
(propertize (truncate-string-to-width str width 0 ?\s t)
'face 'mua/header-face)))
(defun mua/hdrs-contact (msg field width)
"get display string for a list of contacts in a header, truncated for
fitting in WIDTH"
(unless (member field '(:to :from :bcc :cc))
(error "Illegal type for contact"))
(let* ((lst (mua/msg-field msg field))
(str (mapconcat
(lambda (ctc)
(let ((name (car ctc)) (email (cdr ctc)))
(or name email "?"))) lst ",")))
(propertize (truncate-string-to-width str width 0 ?\s t)
'face 'mua/contacts-face)))
(defun mua/hdrs-size (msg width)
"return a string for size of MSG of WIDTH"
(let* ((size (mua/msg-field msg :size))
((str
(cond
((>= size 1000000) (format "%2.1fM" (/ size 1000000.0)))
((and (>= size 1000) (< size 1000000)) (format "%2.1fK" (/ size 1000.0)))
((< size 1000) (format "%d" size)))))
(propertize (truncate-string-to-width str width 0 ?\s)
'face 'mua/header-face))))
(defun mua/hdrs-date (msg width)
"return a string for the date of MSG of WIDTH"
(let* ((date (mua/msg-field msg :date)))
(if date
(propertize (truncate-string-to-width (format-time-string "%x %X" date)
width 0 ?\s) 'face 'mua/date-face))))
(defun mua/hdrs-flags (msg width)
(let* ((flags (mua/msg-field msg :flags))
(flagstr
(mapconcat
(lambda(flag)
(case flag
('unread "U")
('seen "S")
('replied "R")
('attach "a")
('encrypted "x")
('signed "s"))) flags "")))
(propertize (truncate-string-to-width flagstr width 0 ?\s)
'face 'mua/header-face)))
;; some keybinding / functions for basic navigation
(defvar mua/hdrs-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "s" 'mua/hdrs-search)
(define-key map "q" 'mua/quit-buffer)
(define-key map "o" 'mua/hdrs-change-sort)
(define-key map "g" 'mua/hdrs-refresh)
;; navigation
(define-key map "n" 'mua/hdrs-next)
(define-key map "p" 'mua/hdrs-prev)
(define-key map "j" 'mua/hdrs-jump-to-maildir)
;; marking/unmarking/executing
(define-key map "m" (lambda()(interactive)(mua/hdrs-mark 'move)))
(define-key map "d" (lambda()(interactive)(mua/hdrs-mark 'trash)))
(define-key map "D" (lambda()(interactive)(mua/hdrs-mark 'delete)))
(define-key map "u" (lambda()(interactive)(mua/hdrs-mark 'unmark)))
(define-key map "U" (lambda()(interactive)(mua/hdrs-mark 'unmark-all)))
(define-key map "x" 'mua/hdrs-marks-execute)
;; 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") 'mua/hdrs-view)
map)
"Keymap for *mua-headers* buffers.")
(fset 'mua/hdrs-mode-map mua/hdrs-mode-map)
(defun mua/hdrs-next ()
"go to the next line; t if it worked, nil otherwise"
(interactive) ;; TODO: check if next line has path, if not, don't go there
(if (or (/= 0 (forward-line 1)) (not (mua/hdrs-get-path)))
(mua/warn "No message after this one")
(progn
(mua/log "At: %d [%S]" (point) (mua/hdrs-get-path)) t)))
(defun mua/hdrs-prev ()
"go to the previous line; t if it worked, nil otherwise"
(interactive)
(if (or (/= 0 (forward-line -1)) (not (mua/hdrs-get-path)))
(mua/warn "No message before this one")
(progn
(mua/log "At: %d [%S]" (point) (mua/hdrs-get-path)) t)))
(defun mua/hdrs-view ()
(interactive)
(let ((path (mua/hdrs-get-path)))
(if path
(mua/view path (current-buffer))
(mua/warn "No message at point"))))
(defun mua/hdrs-jump-to-maildir ()
"Show the messages in one of the standard folders."
(interactive)
(let ((fld (mua/ask-maildir "Jump to maildir: ")))
(mua/hdrs-search (concat "maildir:" fld))))
(defun mua/hdrs-refresh ()
"Re-run the query for the current search expression, but only
if the search process is not already running"
(interactive)
(when mua/last-expression (mua/hdrs-search mua/last-expression)))
;;; functions for sorting
(defun mua/hdrs-change-sort-order (fieldchar)
"Change the sortfield to FIELDCHAR."
(interactive "cField to sort by ('d', 's', etc.; see mu-headers(1)):\n")
(let ((field
(case fieldchar
(?b "bcc")
(?c "cc")
(?d "date")
(?f "from")
(?i "msgid")
(?m "maildir")
(?p "prio")
(?s "subject")
(?t "to")
(?z "size"))))
(if field
(setq mua/hdrs-sortfield field)
(mua/warn "Invalid sort-field; use one of bcdfimpstz (see mu-headers(1)"))
field))
(defun mua/hdrs-change-sort-direction (dirchar)
"Change the sort direction, either [a]scending or [d]escending."
(interactive)
(setq mua/hdrs-sort-descending
(y-or-n-p "Set sorting direction to descending(y) or ascending(n)")))
(defun mua/hdrs-change-sort ()
"Change thee sort field and direction."
(interactive)
(and (call-interactively 'mua/hdrs-change-sort-order)
(call-interactively 'mua/hdrs-change-sort-direction)))
;;; functions for marking
(defun mua/hdrs-add-marked (src &optional dst)
"Add the message at point to the markings hash"
(let ((bol (line-beginning-position 1)))
(if (gethash bol mua/hdrs-marks-hash)
(mua/warn "Message is already marked")
(progn (puthash bol (cons src dst) mua/hdrs-marks-hash) t))))
(defun mua/hdrs-remove-marked ()
"Remove the message at point from the markings hash"
(let ((bol (line-beginning-position 1)))
(if (not (gethash bol mua/hdrs-marks-hash))
(mua/warn "Message is not marked")
(progn (remhash bol mua/hdrs-marks-hash) t))))
(defun mua/hdrs-set-marker (kar)
"Set the marker at the beginning of this line."
(beginning-of-line 1)
(let ((inhibit-read-only t))
(delete-char 2)
(insert (if kar (format "%c " kar) " "))))
(defun mua/hdrs-mark (action)
"Mark the message at point with one of the symbols: move,
delete, trash, unmark, unmark-all; the latter two are
pseudo-markings."
(let ((target) (src (mua/hdrs-get-path)))
(when src
(case action
(move
(when (mua/hdrs-add-marked src
(mua/ask-maildir "Target maildir: " t)) ;; t->return fullpath
(mua/hdrs-set-marker ?m)))
(trash
(when (mua/hdrs-add-marked src
(concat mua/maildir mua/trash-folder))
(mua/hdrs-set-marker ?d)))
(delete
(when (mua/hdrs-add-marked src "/dev/null")
(mua/hdrs-set-marker ?D)))
(unmark
(when (mua/hdrs-remove-marked)
(mua/hdrs-set-marker nil)))
(unmark-all
(when (y-or-n-p (format "Sure you want to remove all (%d) marks? "
(hash-table-count mua/hdrs-marks-hash)))
(save-excursion
(maphash (lambda (k v) (goto-char k) (mua/hdrs-mark 'unmark))
mua/hdrs-marks-hash))))
(t (error "Unsupported mark type")))
(move-beginning-of-line 2))))
(defun mua/hdrs-marks-execute ()
"execute the actions for all marked messages"
(interactive)
(let ((n-marked (hash-table-count mua/hdrs-marks-hash)))
(if (= 0 n-marked)
(mua/warn "No marked messages")
(when (y-or-n-p
(format "Execute actions for %d marked message(s)? " n-marked))
(save-excursion
(maphash
(lambda(bol v)
(let ((src (car v)) (target (cdr v)) (inhibit-read-only t))
(when (mua/msg-move src target)
(goto-char bol)
(mua/hdrs-remove-marked)
(put-text-property (line-beginning-position 1)
(line-beginning-position 2)
'invisible t)))) ;; when it succeedes, hide msg..)
mua/hdrs-marks-hash))))))
;; functions for creating new message -- reply, forward, and new
(defun mua/hdrs-reply ()
"Reply to message at point."
(interactive)
(let* ((path (mua/hdrs-get-path))
(msg (when path (mua/msg-from-path path))))
(if msg
(mua/msg-compose (mua/msg-create-reply msg
(yes-or-no-p "Reply to all? ")))
(mua/warn "No message at point"))))
(defun mua/hdrs-forward ()
"Forward the message at point."
(interactive)
(let* ((path (mua/hdrs-get-path))
(msg (when path (mua/msg-from-path path))))
(if msg
(mua/msg-compose (mua/msg-create-forward msg))
(mua/warn "No message at point"))))
(defun mua/hdrs-compose ()
"Create a new messge."
(interactive)
(mua/msg-compose (mua/msg-create-new)))
(provide 'mua-hdrs)

483
toys/mua/mua-msg.el Normal file
View File

@ -0,0 +1,483 @@
;;; mua-msg.el -- part of mua, the mu mail user agent
;;
;; Copyright (C) 2011 Dirk-Jan C. Binnema
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; mua
;;; Code:
(eval-when-compile (require 'cl))
;; we use some stuff from gnus...
(require 'message)
(require 'mail-parse)
(require 'html2text)
(require 'mua-common)
(defun mua/msg-from-string (str)
"Get the plist describing an email message, from a string
contain a message sexp; a message sexp looks something like: The
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\"
: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 \" <message body>\"
\)
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 mua/msg-from-path (path)
"Get the an s-expression (plist) describing the e-mail message
at path, or nil if it failed. This functions uses 'mu view' to
obtain the s-expression. For the format, see `mua/msg-from-string'"
(if (not (file-readable-p path))
(progn
(mua/warn "Message is not readable")
(mua/log "not readable: %s" path))
(condition-case nil
(progn (let* ((cmd (concat mua/mu-binary " view --format=sexp " path))
(str (shell-command-to-string cmd)))
(mua/msg-from-string str)))
(error "Failed to read/parse message %s" path))))
(defun mua/msg-body-txt-or-html (msg)
"Get :body-txt, or if not available, :body-html converted to
text, using `html2text'."
(let ((body (mua/msg-field msg :body-txt)))
(unless body
(setq body (mua/msg-field msg :body-html))
(when body
(setq body (with-temp-buffer
(insert body)
(html2text)
(buffer-string)))))
body))
(defun mua/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 `mua/msg-from-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 (mua/msg-body-txt-or-html msg))
(t (plist-get msg field))))
;; TODO: add better error-reporting to mua/msg-move, and make flag handling a
;; bit more lispy
(defun mua/msg-move (src targetdir &optional flags)
"Move message at SRC to TARGETDIR using 'mu mv'; SRC must be
the full, absolute path to a message file, while 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.
Optionally, you can specify the FLAGS for the new file; this must
be a string consisting of one or more of DFNPRST, mean
resp. Deleted, Flagged, New, Passed Replied, Seen and Trash, as
defined in [1].
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.
Function returns the target filename if the move succeeds, or
/dev/null if TARGETDIR was /dev/null; in other cases, it returns
`nil'.
\[1\] http://cr.yp.to/proto/maildir.html."
;; require the flags to be kosher
(when (and flags (let ((case-fold-search nil))
(string-match "[^DFNPRST]" flags))) (error Illegal flags))
(let* ((cmd (concat
mua/mu-binary " mv --printtarget "
(when flags (concat "--flags=" flags " "))
(shell-quote-argument src) " "
(shell-quote-argument targetdir)))
(fulltarget (shell-command-to-string cmd)))
(mua/log cmd)
(mua/log
(if fulltarget (concat "Message has been moved to " fulltarget)
"Message moving failed"))
;; now, if saving worked, anynchronously try to update the database
(when fulltarget ;; note, we don't check the result of the db output
(mua/log "Removing from database: %s" src)
(start-process " *mu-remove*" nil mua/mu-binary "remove" src)
(unless (string= targetdir "/dev/null")
(mua/log "Adding to database: %s" fulltarget)
(start-process " *mu-add*" nil mua/mu-binary "add" fulltarget) t)
)
fulltarget))
;; functions for composing new messages (forward, reply and new)
(defvar mua/msg-citation-prefix "> "
"String to prefix cited message parts with.")
(defvar mua/msg-reply-prefix "Re: "
"String to prefix the subject of replied messages with.")
(defvar mua/msg-forward-prefix "Fwd: "
"String to prefix the subject of forwarded messages with.")
(defconst mua/msg-draft-name "*mua-draft*"
"Name for draft messages.")
(defun mua/msg-user-agent ()
"Return the User-Agent string for mua. This is either the value
of `mua/user-agent', or, if not set, a string based on the
version of mua and emacs."
(or mua/user-agent
(format "mu %s; emacs %s" (mua/mu-binary-version) emacs-version)))
(defun mua/msg-cite-original (msg)
"Cite the body text of MSG, with a \"On %s, %s wrote:\"
line (with the %s's replaced with the date of MSG and the name
or e-mail address of its sender (or 'someone' if nothing
else)), followed of the quoted body of MSG, constructed by by
prepending `mua/msg-citation-prefix' to each line."
(let ((from (mua/msg-field msg :from)))
(concat
(format "On %s, %s wrote:"
(format-time-string "%c" (mua/msg-field msg :date))
(if (and from (car from)) ;; a list ((<name> . <email>))
(or (caar from) (cdar from) "someone")
"someone"))
"\n\n"
(replace-regexp-in-string "^" " > "
(mua/msg-body-txt-or-html msg)))))
(defun mua/msg-recipients-remove (lst email-to-remove)
"Remove the recipient with EMAIL from the recipient list (of
form '( (\"A\" . \"a@example.com\") (\"B\" . \"B@example.com\"))."
(remove-if
(lambda (name-email)
(let ((email (cdr name-email)))
(when email (string= email-to-remove (downcase email))))) lst))
(defun mua/msg-recipients-to-string (lst)
"Convert a recipient list (of form '( (\"A\"
. \"a@example.com\") (\"B\" . \"B@example.com\") (nil
. \"c@example.com\")) into a string of form \"A <@aexample.com>,
B <b@example.com>, c@example.com\."
(mapconcat
(lambda (recip)
(let ((name (car recip)) (email (cdr recip)))
(if name
(format "%s <%s>" name email)
(format "%s" email)))) lst ", "))
(defun mua/msg-hidden-header (hdr val)
"Return user-invisible header to the message (HDR: VAL\n)."
(format "%s: %s\n" hdr val))
;;(propertize (format "%s: %s\n" hdr val) 'invisible t))
(defun mua/msg-header (hdr val)
"Return a header line of the form HDR: VAL\n. If VAL is nil,
return nil."
(when val (format "%s: %s\n" hdr val)))
;;(propertize (format "%s: %s\n" hdr val) 'invisible t))
(defun mua/msg-references-create (msg)
"Construct the value of the References: header based on MSG as
a comma-separated string. Normally, this the concatenation of the
existing References (which may be empty) and the message-id. If
the message-id is empty, returns the old References. If both are
empty, return nil."
(let ((refs (mua/msg-field msg :references))
(msgid (mua/msg-field msg :message-id)))
(if msgid ;; every received message should have one...
(mapconcat 'identity (append refs (list msgid)) ",")
(mapconcat 'identity refs ","))))
(defun mua/msg-to-create (msg reply-all)
"Construct the To: header for a reply-message based on some
message MSG. If REPLY-ALL is nil, this the the Reply-To addresss
of MSG if it exist, or the From:-address othewise. If reply-all
is non-nil, the To: is what was in the old To: with either the
Reply-To: or From: appended, and then the
receiver (i.e. `user-mail-address') removed.
So:
reply-all nil: Reply-To: or From: of MSG
reply-all t : Reply-To: or From: of MSG + To: of MSG - `user-mail-address'
The result is either nil or a string which can be used for the To:-field."
(let ((to-lst (mua/msg-field msg :to))
(reply-to (mua/msg-field msg :reply-to))
(from (mua/msg-field msg :from)))
(if reply-all
(progn ;; reply-all
(setq to-lst ;; append Reply-To:, or if not set, From: if set
(if reply-to (cons `(nil . ,reply-to) to-lst)
(if from (append to-lst from)
to-lst)))
;; and remove myself from To:
(setq to-lst (mua/msg-recipients-remove to-lst user-mail-address))
(mua/msg-recipients-to-string to-lst))
;; reply single
(progn
(or reply-to (mua/msg-recipients-to-string from))))))
(defconst mua/msg-separator "--text follows this line--\n\n"
"separator between headers and body, needed for `message-mode'")
(defun mua/msg-cc-create (msg reply-all)
"Get the list of Cc-addresses for the reply to MSG. If
REPLY-ALL is nil this is simply empty, otherwise it is the same
list as the one in MSG, minus `user-mail-address'. The result of
this function is either nil or a string to be used for the Cc:
field."
(let ((cc-lst (mua/msg-field msg :cc)))
(when (and reply-all cc-lst)
(mu-message-recipients-to-string
(mua/msg-recipients-remove cc-lst
user-mail-address)))))
(defun mua/msg-from-create ()
"Construct a value for the From:-field of the reply to MSG,
based on `user-full-name' and `user-mail-address'; if the latter
is nil, function returns nil."
(when user-mail-address
(if user-full-name
(format "%s <%s>" user-full-name user-mail-address)
(format "%s" user-mail-address))))
(defun mua/msg-create-reply (msg reply-all)
"Create a draft message as a reply to MSG; if REPLY-ALL is
non-nil, reply to all recipients.
A reply message has fields:
From: - see `mu-msg-from-create'
To: - see `mua/msg-to-create'
Cc: - see `mua/msg-cc-create'
Subject: - `mua/msg-reply-prefix' + subject of MSG
then, the following fields, normally hidden from user:
Reply-To: - if `mail-reply-to' has been set
References: - see `mua/msg-references-create'
In-Reply-To: - message-id of MSG
User-Agent - see `mua/msg-user-agent'
Then follows `mua-msg-separator' (for `message-mode' to separate
body from headers)
And finally, the cited body of MSG, as per `mua/msg-cite-original'."
(concat
(mua/msg-header "From" (or (mua/msg-from-create) ""))
(when (boundp 'mail-reply-to)
(mua/msg-header "Reply-To" mail-reply-to))
(mua/msg-header "To" (or (mua/msg-to-create msg reply-all) ""))
(mua/msg-header "Cc" (mua/msg-cc-create msg reply-all))
(mua/msg-hidden-header "User-agent" (mua/msg-user-agent))
(mua/msg-hidden-header "References" (mua/msg-references-create msg))
(mua/msg-hidden-header "In-reply-to" (mua/msg-field msg :message-id))
(mua/msg-header"Subject"
(concat mua/msg-reply-prefix (mua/msg-field msg :subject)))
mua/msg-separator
(mua/msg-cite-original msg)))
;; TODO: attachments
(defun mua/msg-create-forward (msg)
"Create a draft forward message for MSG.
A forward message has fields:
From: - see `mu-msg-from-create'
To: - empty
Subject: - `mua/msg-forward-prefix' + subject of MSG
then, the following fields, normally hidden from user:
Reply-To: - if `mail-reply-to' has been set
References: - see `mua/msg-references-create'
User-Agent - see `mua/msg-user-agent'
Then follows `mua-msg-separator' (for `message-mode' to separate
body from headers)
And finally, the cited body of MSG, as per `mua/msg-cite-original'."
(concat
(mua/msg-header "From" (or (mua/msg-from-for-new) ""))
(when (boundp 'mail-reply-to)
(mua/msg-header "Reply-To" mail-reply-to))
(mua/msg-header "To" "")
(mua/msg-hidden-header "User-agent" (mua/msg-user-agent))
(mua/msg-hidden-header "References" (mua/msg-references-for-reply msg))
(mua/msg-header"Subject"
(concat mua/msg-forward-prefix (mua/msg-field msg :subject)))
mua/msg-separator
(mua/msg-cite-original msg)))
(defun mua/msg-create-new ()
"Create a new message.
A new draft message has fields:
From: - see `mu-msg-from-create'
To: - empty
Subject: - empty
then, the following fields, normally hidden from user:
Reply-To: - if `mail-reply-to' has been set
User-Agent - see `mua/msg-user-agent'
Then follows `mua-msg-separator' (for `message-mode' to separate
body from headers)."
(concat
(mua/msg-header "From" (or (mua/msg-from-for-new) ""))
(when (boundp 'mail-reply-to)
(mua/msg-header "Reply-To" mail-reply-to))
(mua/msg-header "To" "")
(mua/msg-hidden-header "User-agent" (mua/msg-user-agent))
(mua/msg-header "Subject" "")
mua/msg-separator))
(defconst mua/msg-file-prefix "mua" "prefix for mua-generated
mail files; we use this to ensure that our hooks don't mess
with non-mua-generated messages")
(defun mua/msg-draft-file-name ()
"Create a Maildir-compatible[1], unique file name for a draft
message.
[1]: see http://cr.yp.to/proto/maildir.html"
(format "%s-%x-%x.%s:2,D" ;; 'D': rarely used, but hey, it's available
mua/msg-file-prefix
(format-time-string "%Y%m%d" (current-time))
(emacs-pid)
(random t)
(replace-regexp-in-string "[:/]" "_" (system-name))))
(defun mua/msg-compose (str)
"Create a new draft message in the drafts folder with STR as
its contents, and open this message file for editing
The name of the draft folder is constructed from the concatenation of
`mua/maildir' and `mua/drafts-folder' (therefore, these must be set).
The message file name is a unique name determined by
`mua/msg-draft-file-name'.
The initial STR would be created from either `mua/msg-create-reply',
`mua/msg-create-forward' or `mua/msg-create-new'. The editing buffer is
using Gnus' `message-mode'."
(unless mua/maildir (error "mua/maildir not set"))
(unless mua/drafts-folder (error "mua/drafts-folder not set"))
;; write our draft message to the the drafts folder
(let ((draftfile (concat mua/maildir "/" mua/drafts-folder "/cur/"
(mua/msg-draft-file-name))))
(with-temp-file draftfile (insert str))
(find-file draftfile)
(rename-buffer mua/msg-draft-name t)
(message-mode)
(message-goto-body)))
(defun mua/msg-is-mua-message ()
"Check whether the current buffer refers a mua-message based on
the buffer file name; this is used in hooks we install on
message-mode to ensure we only do things with mua-generated
messages (mua is not the only user of `message-mode' after all)"
(let* ((fname (buffer-file-name))
(match (and fname (string-match mua/msg-file-prefix fname))))
(and (numberp match) (= 0 match))))
;; we simply check if file starts with `mu-msg-file-prefix'
(defun mua/msg-save-to-sent ()
"function that moves the current message to the sent folder"
(if (mua/msg-is-mua-message)
(unless mua/sent-folder (error "mua/sent-folder not set"))
(let ((sent-msg ;; note, the "" parameter remove the D 'Draft'-flag
(mua/msg-move (buffer-file-name) mua/sent-folder "")))
(if (sent-msg) ;; change our buffer file-name
(set-visited-file-name sent-msg t t)
(mua/warn "Failed to save message to the Sent-folder")))))
;; (defun mua/msg-set-replied-flag ()
;; "find the message we replied to, and set its 'Replied' flag."
;; (if (mua/msg-is-mua-message)
;; (let ((msgid (mail-header-parse-addresses
;; (message-field-value "In-Reply-To")))
;; (path (and msgid (shell-command-to-string
;; (concat mua/mu-binary
;; " find msgid:" msgid " --exec=echo | head -1")))))
;; (if path
;; (mu-mv)
;; add-hook
;; add-hook
(provide 'mua-msg)

221
toys/mua/mua-view.el Normal file
View File

@ -0,0 +1,221 @@
;;; mua-view.el -- part of mua, the mu mail user agent
;;
;; Copyright (C) 2011 Dirk-Jan C. Binnema
;; Author: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; Maintainer: Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; mu
;;; Code:
(eval-when-compile (require 'cl))
(require 'mua-common)
(require 'mua-msg)
(defconst mua/view-buffer-name " *mua-view*"
"buffer name for mua/view buffers")
(defvar mua/view-headers
'(:from :to :cc :subject :flags :date :attachments)
"fields to display in the message view")
(defvar mua/hdrs-buffer nil
"headers buffer for the view")
(defun mua/view (path headersbuf)
"display message at PATH in a new buffer; note that the action
of viewing a message may cause it to be moved/renamed; this
function returns the resulting name. PARENTBUF refers to the
buffer who invoked this view; this allows us to return there when
we quit from this view. Also, if PARENTBUF is a find buffer (ie.,
has mu-headers-mode as its major mode), this allows various
commands (navigation, marking etc.) to be applied to this
buffer."
(let* ((msg (mua/msg-from-path path))
(buf (get-buffer-create mua/view-buffer-name))
(str (mua/view-message msg)))
(when (and msg str)
(switch-to-buffer buf)
(let ((inhibit-read-only t))
(erase-buffer)
(insert str))
(mua/view-mode)
(setq ;; these are buffer-local
mua/hdrs-buffer headersbuf
mua/parent-buffer headersbuf)
(goto-char (point-min)))))
(defun mua/view-message (msg)
"construct a display string for the message"
(let ((hdrs
(mapconcat
(lambda (field)
(case field
(:subject (mua/view-header msg "Subject" :subject))
(:path (mua/view-header msg "Path" :path))
(:to (mua/view-contacts msg field))
(:from (mua/view-contacts msg field))
(:cc (mua/view-contacts msg field))
(:bcc (mua/view-contacts msg field))
(:date (mua/view-date msg))
(:flags (mua/view-flags msg))
(:size (mua/view-size msg))
(:attachments (mua/view-attachments msg))
(t (error "Unsupported field: %S" field))))
mua/view-headers ""))
(body (mua/msg-body-txt-or-html msg)))
(concat hdrs "\n" body)))
(defun mua/view-header-string (key val face)
(if val
(concat
(propertize key 'face 'mua/header-title-face) ": "
(propertize val 'face face) "\n")
""))
(defun mua/view-header (msg key field)
"show header FIELD for MSG with KEY. ie. <KEY>: value-of-FIELD\n"
(mua/view-header-string key (mua/msg-field msg field) 'mua/header-face))
(defun mua/view-contacts (msg field)
(unless (member field '(:to :from :bcc :cc))
(error "Illegal type for contact"))
(let* ((lst (mua/msg-field msg field))
(contacts
(when lst
(mapconcat
(lambda(c) (let ((name (car c)) (email (cdr c)))
(if name
(format "%s <%s>" name email)
(format "%s" email)))) lst ", "))))
(if contacts
(mua/view-header-string
(case field (:to "To") (:from "From") (:bcc "Bcc") (:cc "Cc"))
contacts 'mua/contacts-face)
"")))
(defun mua/view-date (msg)
(let* ((date (mua/msg-field msg :date))
(datestr (when date (format-time-string "%c" date))))
(mua/view-header-string "Date" datestr 'mua/header-face)))
(defun mua/view-size (msg)
(let* ((size (mua/msg-field msg :size))
(sizestr (when size (format "%d bytes"))))
(mua/view-header-string "Size" sizestr 'mua-header-face)))
(defun mua/view-flags (msg)
""
"" ;; todo
)
(defun mua/view-attachments (msg)
""
"" ;; todo
)
(defvar mua/view-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "q" 'mua/quit-buffer)
(define-key map "s" 'mua/view-search)
(define-key map "f" 'mua/view-forward)
(define-key map "r" 'mua/view-reply)
(define-key map "c" 'mua/view-compose)
;; navigation between messages
(define-key map "n" 'mua/view-next)
(define-key map "p" 'mua/view-prev)
;; marking/unmarking
(define-key map "d" '(lambda (mua/view-mark 'trash)))
(define-key map "D" '(lambda (mua/view-mark 'delete)))
(define-key map "m" '(lambda (mua/view-mark 'move)))
(define-key map "u" '(lambda (mua/view-mark 'unmark)))
(define-key map "x" 'mua/view-marked-execute)
map)
"Keymap for \"*mua-view*\" buffers.")
(fset 'mua/view-mode-map mua/view-mode-map)
(defun mua/view-mode ()
"major mode for viewing an e-mail message"
(interactive)
(kill-all-local-variables)
(use-local-map mua/view-mode-map)
(make-local-variable 'mua/parent-buffer)
(make-local-variable 'mua/hdrs-buffer)
(make-local-variable 'mua/path)
(setq major-mode 'mua/view-mode mode-name "*mu-view*")
(setq truncate-lines t buffer-read-only t))
(defmacro mua/with-hdrs-buffer (&rest body)
"Execute the forms in BODY with the mua/hdrs-buffer temporarily current.
Note that this actually switches the buffer, and changes to point
etc. persist."
(declare (indent 1) (debug t))
`(let ((oldbuf (current-buffer)))
(if (buffer-live-p mua/hdrs-buffer)
(progn
(set-buffer mua/hdrs-buffer)
(progn ,@body)
(set-buffer oldbuf))
(mua/warn "hdrs buffer is dead"))))
(defun mua/view-next ()
"move to the next message; note, this will replace the current
buffer"
(interactive)
(mua/with-hdrs-buffer
(when (mua/hdrs-next) (mua/hdrs-view))))
(defun mua/view-prev ()
"move to the previous message; note, this will replace the
current buffer"
(interactive)
(mua/with-hdrs-buffer
(when (mua/hdrs-prev) (mua/hdrs-view))))
(defun mua/view-reply ()
"Reply to the current message."
(interactive) (mua/with-hdrs-buffer (mua/hdrs-reply)))
(defun mua/view-forward ()
"Reply to the current message."
(interactive) (mua/with-hdrs-buffer (mua/hdrs-forward)))
(defun mua/view-compose ()
"Write a new message."
(interactive) (mua/with-hdrs-buffer (mua/hdrs-compose)))
(provide 'mua-view)