mu/emacs/mm.el

;;; mm.el -- part of mm, 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:

;;; Code:

(eval-when-compile (require 'cl))

(require 'mm-hdrs)
(require 'mm-view)
(require 'mm-main)
(require 'mm-send)
(require 'mm-proc)

(require 'mm-version) ;; auto-generated

;; mm-version.el is autogenerated, and defines mm/mu-version
(require 'mm-version)

;; Customization

(defgroup mm nil
  "mm - the mu mail client"
  :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 specify 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)

(defcustom mm/get-mail-command nil
  "Shell command to run to retrieve new mail; e.g. 'offlineimap' or
'fetchmail'."
  :type 'string
  :group 'mm
  :safe 'stringp)

(defcustom mm/attachment-dir (expand-file-name "~/")
  "Default directory for saving attachments."
  :type 'string
  :group 'mm
  :safe 'stringp)

(defvar mm/user-mail-address-regexp "$^"
  "Regular expression matching the user's mail address(es). This is
used to distinguish ourselves from others, e.g. when replying and
in :from-or-to headers. By default, match nothing.")

(defvar mm/date-format-long "%c"
  "Date format to use in the message view, in the format of
  `format-time-string'.")

(defvar mm/search-results-limit 500
  "Maximum number of search results (or -1 for unlimited). Since
limiting search results speeds up searches significantly, it's
useful to limit this. Note, to ignore the limit, use a prefix
argument (C-u) before invoking the search.")


(defvar mm/debug nil
  "When set to non-nil, log debug information to the *mm-log* buffer.")

(defvar mm/bookmarks
  '( ("flag:unread AND NOT flag:trashed" "Unread messages"      ?u)
     ("date:today..now"                  "Today's messages"     ?t)
     ("date:7d..now"                     "Last 7 days"          ?w)
     ("mime:image/*"                     "Messages with images" ?p))
  "A list of pre-defined queries; these will show up in the main
screen. Each of the list elements is a three-element list of the
form (QUERY DESCRIPTION KEY), where QUERY is a string with a mu
query, DESCRIPTION is a short description of the query (this will
show up in the UI), and KEY is a shortcut key for the query.")


;; Folders

(defgroup mm/folders nil
  "Special folders for mm."
  :group 'mm)

;; (defcustom mm/inbox-folder nil
;;   "Your Inbox folder, relative to `mm/maildir', e.g. \"/Inbox\"."
;;   :type 'string
;;   :safe 'stringp
;;   :group 'mm/folders)

(defcustom mm/sent-folder nil
  "Your folder for sent messages, relative to `mm/maildir',
  e.g. \"/Sent Items\"."
  :type 'string
  :safe 'stringp
  :group 'mm/folders)

(defcustom mm/draft-folder nil
  "Your folder for draft messages, relative to `mm/maildir',
  e.g. \"/drafts\""
  :type 'string
  :safe 'stringp
  :group 'mm/folders)

(defcustom mm/trash-folder nil
  "Your folder for trashed messages, relative to `mm/maildir',
  e.g. \"/trash\"."
  :type 'string
  :safe 'stringp
  :group 'mm/folders)


(defcustom mm/maildir-shortcuts nil
  "A list of maildir shortcuts to enable quickly going to the
 particular for, or quickly moving messages towards them (i.e.,
 archiving or refiling). The list contains elements of the form
 (maildir . shortcut), where MAILDIR is a maildir (such as
\"/archive/\"), and shortcut a single shortcut character. With
this, in the header buffer and view buffer you can execute
`mm/mark-for-move-quick' (or 'm', by default) or
`mm/jump-to-maildir-quick' (or 'j', by default), followed by the
designated shortcut character for the maildir.")

;; the headers view
(defgroup mm/headers nil
  "Settings for the headers view."
  :group 'mm)


(defcustom mm/headers-fields
    '( (:date          .  25)
       (:flags         .   6)
       (:from          .  22)
       (:subject       .  40))
  "A list of header fields to show in the headers buffer, and their
  respective widths in characters. A width of `nil' means
  'unrestricted', and this is best reserved fo the rightmost (last)
  field. For the complete list of available headers, see `mm/header-names'"
       :type (list 'symbol)
       :group 'mm/headers)

(defcustom mm/headers-date-format "%x %X"
  "Date format to use in the headers view, in the format of
  `format-time-string'."
  :type  'string
  :group 'mm/headers)


;; the message view
(defgroup mm/view nil
  "Settings for the message view."
  :group 'mm)

(defcustom mm/view-fields
  '(:from :to :cc :subject :flags :date :maildir :path :attachments)
  "Header fields to display in the message view buffer. For the
complete list of available headers, see `mm/header-names'."
  :type (list 'symbol)
  :group 'mm/view)

(defcustom mm/view-date-format "%c"
  "Date format to use in the message view, in the format of
  `format-time-string'."
  :type 'string
  :group 'mm/headers)

;; Composing / Sending messages
(defgroup mm/compose nil
  "Customizations for composing/sending messages."
  :group 'mm)

(defcustom mm/msg-citation-prefix "> "
  "String to prefix cited message parts with."
  :type 'string
  :group 'mm/compose)

(defcustom mm/msg-reply-prefix "Re: "
  "String to prefix the subject of replied messages with."
  :type 'string
  :group 'mm/compose)

(defcustom mm/msg-forward-prefix "Fwd: "
  "String to prefix the subject of forwarded messages with."
  :type 'string
  :group 'mm/compose)

(defcustom mm/user-agent nil
  "The user-agent string; leave at `nil' for the default."
  :type 'string
  :group 'mm/compose)



;; 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 :slant italic))
  "Face for an mm message header that has been moved to some
folder (it's still visible in the search results, since we cannot
be sure it no longer matches)."
  :group 'mm/faces)

(defface mm/trashed-face
  '((t :inherit font-lock-comment-face :strike-through t))
  "Face for an message header in the trash folder."
  :group 'mm/faces)

(defface mm/draft-face
  '((t :inherit font-lock-string-face))
  "Face for a draft message header (i.e., a message with the draft
flag set)."
  :group 'mm/faces)

(defface mm/header-face
  '((t :inherit default))
  "Face for an mm header without any special flags."
  :group 'mm/faces)

(defface mm/title-face
  '((t :inherit font-lock-type-face))
  "Face for an mm title."
  :group 'mm/faces)

(defface mm/view-header-key-face
  '((t :inherit font-lock-builtin-face))
  "Face for the header title (such as \"Subject\" in the message view)."
  :group 'mm/faces)

(defface mm/view-header-value-face
  '((t :inherit font-lock-doc-face))
  "Face for the header value (such as \"Re: Hello!\" in the message view)."
  :group 'mm/faces)

(defface mm/view-link-face
  '((t :inherit font-lock-type-face :underline t))
  "Face for showing URLs and attachments in the message view."
  :group 'mm/faces)

(defface mm/highlight-face
  '((t :inherit font-lock-pseudo-keyword-face :bold t))
  "Face for highlighting things."
  :group 'mm/faces)

(defface mm/view-url-number-face
  '((t :inherit font-lock-reference-face :bold t))
  "Face for the number tags for URLs."
  :group 'mm/faces)

(defface mm/view-attach-number-face
  '((t :inherit font-lock-variable-name-face :bold t))
  "Face for the number tags for attachments."
  :group 'mm/faces)

(defface mm/view-footer-face
  '((t :inherit font-lock-comment-face))
  "Face for message footers (signatures)."
  :group 'mm/faces)

(defface mm/hdrs-marks-face
  '((t :inherit font-lock-preprocessor-face))
  "Face for the mark in the headers list."
  :group 'mm/faces)

(defface mm/system-face
  '((t :inherit font-lock-comment-face :slant italic))
  "Face for system message (such as the footers for message
headers)."
  :group 'mm/faces)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal variables / constants

(defconst mm/header-names
  '( (:attachments   .  "Attach")
     (:bcc           .  "Bcc")
     (:cc            .  "Cc")
     (:date          .  "Date")
     (:flags         .  "Flags")
     (:from          .  "From")
     (:from-or-to    .  "From/To")
     (:maildir       .  "Maildir")
     (:path          .  "Path")
     (:subject       .  "Subject")
     (:to            .  "To"))
"A alist of all possible header fields; this is used in the UI (the
column headers in the header list, and the fields the message
view). Most fields should be self-explanatory. A special one is
`:from-or-to', which is equal to `:from' unless `:from' matches ,
in which case it will be equal to `:to'.)")


;; mm startup function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mm ()
  "Start mm. We do this by sending a 'ping' to the mu server
process, and start the main view if the 'pong' we receive from the
server has the expected values."
  (interactive)
  (if (buffer-live-p mm/main-buffer-name)
    (switch-to-buffer mm/main-buffer-name)
    (setq mm/proc-pong-func
      (lambda (version doccount)
	(unless (string= version mm/mu-version)
	  (error "mu server has version %s, but we need %s"
	    version mm/mu-version))
	(mm/main-view)))
    (mm/proc-ping)))

(defun mm/ask-maildir (prompt)
  "Ask the user for a shortcut (using PROMPT) as defined in
`mm/maildir-shortcuts', then return the corresponding folder
name. If the special shortcut 'o' (for _o_ther) is used, or if
`mm/maildir-shortcuts is not defined, let user choose from all
maildirs under `mm/maildir."
  (unless mm/maildir (error "`mm/maildir' is not defined"))
  (if (not mm/maildir-shortcuts)
    (ido-completing-read prompt (mm/get-sub-maildirs mm/maildir))
    (let* ((mlist (append mm/maildir-shortcuts '(("ther" . ?o))))
	    (fnames
	      (mapconcat
		(lambda (item)
		  (concat
		    "["
		    (propertize (make-string 1 (cdr item)) 'face 'mm/view-link-face)
		    "]"
		    (car item)))
		mlist ", "))
	    (kar (read-char (concat prompt fnames))))
      (if (= kar ?o) ;; user chose 'other'?
	(ido-completing-read prompt (mm/get-sub-maildirs mm/maildir))
	(or
	  (car-safe (find-if (lambda (item) (= kar (cdr item))) mm/maildir-shortcuts))
	  (error "Invalid shortcut '%c'" kar))))))



(defun mm/ask-bookmark (prompt)
  "Ask the user for a bookmark (using PROMPT) as defined in
`mm/bookmarks', then return the corresponding query."
  (unless mm/bookmarks (error "`mm/bookmarks' is not defined"))
  (let* ((bmarks
	   (mapconcat
	     (lambda (bm)
	       (let ((query (nth 0 bm)) (title (nth 1 bm)) (key (nth 2 bm)))
		 (concat
		   "[" (propertize (make-string 1 key) 'face 'mm/view-link-face) "]"
		   title))) mm/bookmarks ", "))
	  (kar (read-char (concat prompt bmarks)))
	  (chosen-bm
	    (find-if (lambda (bm) (= kar (nth 2 bm))) mm/bookmarks)))
    (unless chosen-bm (error "Invalid shortcut '%c'" kar))
    (nth 0 chosen-bm)))



(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))



;;; 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)
		 ('attach    ?a)
		 ('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))))))


(defun mm/display-size (size)
  "Get a string representation of SIZE (in bytes)."
  (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))
    (t "<unknown>")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide 'mm)