From bb5028da7255fee2f930d4ac95602145597d98f6 Mon Sep 17 00:00:00 2001 From: "Dirk-Jan C. Binnema" Date: Sun, 2 Oct 2011 21:35:03 +0300 Subject: [PATCH] * mm: many updates (still WIP) --- toys/mm/mm-hdrs.el | 27 ++++- toys/mm/mm-proc.el | 56 ++++------ toys/mm/mm-send.el | 269 ++++++++++++++++++--------------------------- toys/mm/mm-view.el | 8 +- toys/mm/mm.el | 2 +- 5 files changed, 156 insertions(+), 206 deletions(-) diff --git a/toys/mm/mm-hdrs.el b/toys/mm/mm-hdrs.el index 7efcae8f..c774c209 100644 --- a/toys/mm/mm-hdrs.el +++ b/toys/mm/mm-hdrs.el @@ -430,10 +430,18 @@ work well." (defun mm/hdrs-compose (compose-type) "Compose either a reply/forward based on the message at point. or start editing it. COMPOSE-TYPE is either `reply', `forward' or -`draft'." - (let ((docid (mm/hdrs-get-docid))) - (unless docid (error "No message at point.")) - (mm/proc-compose-msg docid compose-type))) +`edit'." + (if (eq compose-type 'new) + (mm/send-compose-handler 'new) + (let ((docid (mm/hdrs-get-docid))) + (when (and (not docid) (not )) + (error "No message at point.")) + (cond + ((member compose-type '(reply forward)) + (mm/proc-compose compose-type docid)) + ((eq compose-type 'edit) + (mm/proc-compose 'edit docid)) + (t (error "invalid compose type %S" compose-type)))))) (defun mm/hdrs-docid-is-marked (docid) @@ -609,14 +617,21 @@ folder (`mm/trash-folder')." (with-current-buffer mm/hdrs-buffer (mm/hdrs-compose 'forward))) +(defun mm/compose-new () + "Compose a new, empty message." + (interactive) + (mm/hdrs-compose 'new)) + (defun mm/edit-draft () "Start editing the existing draft message at point." (interactive) (with-current-buffer mm/hdrs-buffer - (mm/hdrs-compose 'draft))) + (mm/hdrs-compose 'edit))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide 'mm-hdrs) - diff --git a/toys/mm/mm-proc.el b/toys/mm/mm-proc.el index a1bdc959..a6c1ce65 100644 --- a/toys/mm/mm-proc.el +++ b/toys/mm/mm-proc.el @@ -240,8 +240,8 @@ updated as well, with all processed sexp data removed." ;; start composing a new message ((plist-get sexp :compose) (funcall mm/proc-compose-func - (plist-get sexp :compose) - (plist-get sexp :action))) + (plist-get sexp :compose-type) + (plist-get sexp :compose))) ;; get some info ((plist-get sexp :info) @@ -345,10 +345,10 @@ or (:error ) sexp, which are handled my `mm/proc-update-func' and ;; note, we send the maildir, *not* the full path (mm/proc-send-command "move %d \"%s\" \"%s\"" docid targetmdir flagstr))) -(defun mm/proc-flag-msg (docid flags) - "Set FLAGS for the message identified by DOCID." +(defun mm/proc-flag (docid-or-msgid flags) + "Set FLAGS for the message identified by either DOCID-OR-MSGID." (let ((flagstr (if (stringp flags) flags (mm/flags-to-string flags)))) - (mm/proc-send-command "flag %d %s" docid flagstr))) + (mm/proc-send-command "flag %S %s" docid-or-msgid flagstr))) (defun mm/proc-index (maildir) "Update the message database for MAILDIR." @@ -373,43 +373,35 @@ set to e.g. '/drafts'; if this works, we will receive (:info :path be delivered to the function registered as `mm/proc-message-func'." (mm/proc-send-command "view %d" docid)) -(defun mm/proc-compose-msg (docid compose-type) +(defun mm/proc-compose (compose-type docid) "Start composing a message with DOCID and COMPOSE-TYPE (a symbol, - either `forward', `reply' or `draft'. + either `forward', `reply' or `edit'. The result will be delivered to the function registered as `mm/proc-compose-func'." - (unless (member compose-type '(forward reply draft)) + (unless (member compose-type '(forward reply edit)) (error "Unsupported compose-type")) (mm/proc-send-command "compose %s %d" (symbol-name compose-type) docid)) +(defconst mm/update-buffer-name "*update*" + "*internal* Name of the buffer to download mail") + (defun mm/proc-retrieve-mail-update-db () "Try to retrieve mail (using the user-provided shell command), and update the database afterwards." - (when mm/get-mail-command - (let ((buf (get-buffer-create "*mm-retrieve*")) - (cmd mm/get-mail-command)) - (message "Retrieving mail...") - (let ((proc (start-process "*mm-retrieve*" buf "sh" "-c" cmd))) - (set-process-sentinel proc 'mm/proc-retrieve-mail-sentinel))))) - - -(defun mm/proc-retrieve-mail-sentinel (proc msg) - "Function that will be called when the mail retrieval process -terminates." - (let ((status (process-status proc)) (code (process-exit-status proc))) - (cond - ((eq status 'signal) - (cond - ((eq code 9) (message "the mail retrieval process has been stopped")) - (t (message (format "mu server process received signal %d" code))))) - ((eq status 'exit) - (if (eq code 0) ;; all went well, it seems - (progn - (message "Updating the database...") - (mm/proc-index mm/maildir)) - (progn - (message "Received code %d from mail retrieval process" code))))))) + (unless mm/get-mail-command + (error "`mm/get-mail-command' is not defined")) + (let ((buf (get-buffer-create mm/update-buffer-name))) + (split-window-vertically -8) + (switch-to-buffer-other-window buf) + (with-current-buffer buf + (erase-buffer)) + (message "Retrieving mail...") + (call-process mm/get-mail-command nil buf t) + (message "Updating the database...") + (mm/proc-index mm/maildir) + (with-current-buffer buf + (kill-buffer-and-window)))) (provide 'mm-proc) diff --git a/toys/mm/mm-send.el b/toys/mm/mm-send.el index 1b579133..f831116c 100644 --- a/toys/mm/mm-send.el +++ b/toys/mm/mm-send.el @@ -109,10 +109,6 @@ or if not available, :body-html converted to text)." (format "%s <%s>" name email) (format "%s" email)))) lst ", ")) -(defun mm/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 mm/msg-header (hdr val) "Return a header line of the form HDR: VAL\n. If VAL is nil, @@ -126,10 +122,12 @@ 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 (plist-get msg :references)) - (msgid (plist-get msg :message-id))) - (if msgid ;; every received message should have one... - (mapconcat 'identity (append refs (list msgid)) ",") - (mapconcat 'identity refs ",")))) + (old-msgid (plist-get msg :message-id))) + (when old-msgid + (setq refs (append refs (list old-msgid))) + (mapconcat + (lambda (msgid) (format "<%s>" msgid)) + refs ",")))) (defun mm/msg-to-create (msg reply-all) "Construct the To: header for a reply-message based on some @@ -183,12 +181,8 @@ nil, function returns nil." (format "%s <%s>" user-full-name user-mail-address) (format "%s" user-mail-address)))) -(defconst mm/reply-docid-header "Reply-docid" - "*internal* The reply-to-docid header.") - -(defun mm/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. +(defun mm/msg-create-reply (msg) + "Create a draft message as a reply to MSG. A reply message has fields: From: - see `mu-msg-from-create' @@ -206,29 +200,30 @@ Then follows `mail-header-separator' (for `message-mode' to separate body from headers) And finally, the cited body of MSG, as per `mm/msg-cite-original'." - (concat - (mm/msg-header "From" (or (mm/msg-from-create) "")) - (when (boundp 'mail-reply-to) - (mm/msg-header "Reply-To" mail-reply-to)) + (let* ((recipnum (+ (length (plist-get msg :to)) + (length (plist-get msg :cc)))) + (reply-all (when (> recipnum 1) + (yes-or-no-p + (format "Reply to all ~%d recipients? " + (+ recipnum)))))) + (concat + (mm/msg-header "From" (or (mm/msg-from-create) "")) + (when (boundp 'mail-reply-to) + (mm/msg-header "Reply-To" mail-reply-to)) - (mm/msg-header "To" (or (mm/msg-to-create msg reply-all) "")) - (mm/msg-header "Cc" (mm/msg-cc-create msg reply-all)) + (mm/msg-header "To" (or (mm/msg-to-create msg reply-all) "")) + (mm/msg-header "Cc" (mm/msg-cc-create msg reply-all)) - (mm/msg-hidden-header "User-agent" (mm/msg-user-agent)) - (mm/msg-hidden-header mm/reply-docid-header (plist-get msg :docid)) - (mm/msg-hidden-header "References" (mm/msg-references-create msg)) + (mm/msg-header "User-agent" (mm/msg-user-agent)) + (mm/msg-header "References" (mm/msg-references-create msg)) - (mm/msg-hidden-header "In-reply-to" (plist-get msg :message-id)) + (mm/msg-header "In-reply-to" (format "<%s>" (plist-get msg :message-id))) - (mm/msg-header "Subject" - (concat mm/msg-reply-prefix (plist-get msg :subject))) + (mm/msg-header "Subject" + (concat mm/msg-reply-prefix (plist-get msg :subject))) - (propertize mail-header-separator 'read-only t 'intangible t) '"\n" - (mm/msg-cite-original msg))) - - -(defconst mm/forward-docid-header "Forward-docid" - "*internal* The reply-to-docid header.") + (propertize mail-header-separator 'read-only t 'intangible t) '"\n" + (mm/msg-cite-original msg)))) ;; TODO: attachments (defun mm/msg-create-forward (msg) @@ -254,13 +249,10 @@ And finally, the cited body of MSG, as per `mm/msg-cite-original'." (mm/msg-header "Reply-To" mail-reply-to)) (mm/msg-header "To" "") - (mm/msg-hidden-header "User-agent" (mm/msg-user-agent)) - (mm/msg-hidden-header "References" (mm/msg-references-create msg)) - (mm/msg-hidden-header mm/forward-docid-header (plist-get msg :docid)) - + (mm/msg-header "User-agent" (mm/msg-user-agent)) + (mm/msg-header "References" (mm/msg-references-create msg)) (mm/msg-header"Subject" (concat mm/msg-forward-prefix (plist-get msg :subject))) - (propertize mail-header-separator 'read-only t 'intangible t) "\n" (mm/msg-cite-original msg))) @@ -283,63 +275,76 @@ body from headers)." (mm/msg-header "From" (or (mm/msg-from-create) "")) (when (boundp 'mail-reply-to) (mm/msg-header "Reply-To" mail-reply-to)) - (mm/msg-header "To" "") - (mm/msg-hidden-header "User-agent" (mm/msg-user-agent)) + (mm/msg-header "User-agent" (mm/msg-user-agent)) (mm/msg-header "Subject" "") (propertize mail-header-separator 'read-only t 'intangible t) "\n")) -(defconst mm/msg-prefix "mm" "prefix for mm-generated -mail files; we use this to ensure that our hooks don't mess -with non-mm-generated messages") +(defun mm/msg-open-draft (compose-type &optional msg) + "Open a draft file for a new message, creating it if it does not +already exist, and optionally fill it with STR. Function also adds +the new message to the database. When the draft message is added to +the database, `mm/path-docid-map' will be updated, so that we can +use the new docid. Return the full path to the new message." + (let ((draft + (concat mm/maildir mm/drafts-folder "/cur/" + (format "%s-%x%x:2,D" ;; 'D': rarely used, but hey, it's available + (format-time-string "%Y%m%d" (current-time)) + (emacs-pid) + (random t)))) ;; TODO: include hostname + (str (case compose-type + (reply (mm/msg-create-reply msg)) + (forward (mm/msg-create-forward msg)) + (new (mm/msg-create-new)) + (t (error "unsupported compose-type %S" compose-type))))) + (when str + (with-temp-file draft + (insert str) + (write-file draft))) -(defun mm/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:2,D" ;; 'D': rarely used, but hey, it's available - (format-time-string "%Y%m%d" (current-time)) - (emacs-pid) - (random t))) -;;; (replace-regexp-in-string "[:/]" "_" (system-name)))) + ;; save our file immediately, add add it to the db; thus, we can retrieve + ;; the new docid from `mm/path-docid-map'. + (mm/proc-add draft mm/drafts-folder) + draft)) -(defun mm/msg-compose (str &optional parent-docid reply-or-forward) - "Create a new draft message in the drafts folder with STR as -its contents, and open this message file for editing. -For replies/forewards, you can specify PARENT-DOCID so the -corresponding message can get its Passed or Replied flag set when -this one is sent. If PARENT-DOCID is specified, also -reply-or-forward should be specified, which is a symbol, either -'reply or 'forward. +(defun mm/send-compose-handler (compose-type &optional msg) + "Create a new draft message, or open an existing one. -The name of the draft folder is constructed from the concatenation of - `mm/maildir' and `mm/drafts-folder' (therefore, these must be set). +COMPOSE-TYPE determines the kind of message to compose and is a +symbol, either `reply', `forward', `edit', `new'. `edit' is for +editing existing messages. + +When COMPOSE-TYPE is `reply' or `forward', MSG should be a message +plist. If COMPOSE-TYPE is `new', MSG should be nil. + +The name of the draft folder is constructed from the concatenation + of `mm/maildir' and `mm/drafts-folder' (therefore, these must be + set). The message file name is a unique name determined by `mm/msg-draft-file-name'. The initial STR would be created from either `mm/msg-create-reply', -`mm/msg-create-forward' or `mm/msg-create-new'. The editing buffer is +ar`mm/msg-create-forward' or `mm/msg-create-new'. The editing buffer is using Gnus' `message-mode'." (unless mm/maildir (error "mm/maildir not set")) (unless mm/drafts-folder (error "mm/drafts-folder not set")) + (let ((draft + (if (member compose-type '(reply forward new)) + (mm/msg-open-draft compose-type msg) + (if (eq compose-type 'edit) + (plist-get msg :path) + (error "unsupported compose-type %S" compose-type))))) - ;; write our draft message to the the drafts folder - (let ((draftfile (concat mm/maildir mm/drafts-folder "/cur/" - (mm/msg-draft-file-name)))) - (with-temp-file draftfile (insert str)) - (find-file draftfile) - (rename-buffer mm/msg-draft-name t) + (unless (file-readable-p draft) + (error "Cannot read %s" path)) - ;; save our file immediately, add add it to the db; thus, we can retrieve - ;; the new docid from `mm/path-docid-map'. - (write-file draftfile) - (mm/proc-add draftfile mm/drafts-folder) + (find-file draft) (message-mode) (make-local-variable 'write-file-functions) - + ;; update the db when the file is saved...] (add-to-list 'write-file-functions (lambda() (mm/proc-add (buffer-file-name) mm/drafts-folder))) @@ -350,56 +355,17 @@ using Gnus' `message-mode'." (let ((message-hidden-headers `("^References:" "^Face:" "^X-Face:" "^X-Draft-From:" - ,(concat mm/reply-docid-header ":") - ,(concat mm/forward-docid-header ":") "^User-agent:"))) (message-hide-headers)) (message-goto-body))) - - -(defun mm/send-compose-handler (msg compose-type) - "This function is registered as the compose handler in -`mm/proc-compose-func', and will be called when a new message is to -be composed, based on some existing one. MSG is a message sexp, -while COMPOSE-TYPE is a symbol, either 'reply or 'forward. - -In case of 'forward, create a draft forward for MSG, and switch to -an edit buffer with the draft message. - -In case of 'reply, create a draft reply to MSG, and swith to an -edit buffer with the draft message" - (cond - ((eq compose-type 'forward) ;; forward - (when (mm/msg-compose (mm/msg-create-forward msg) - (plist-get msg :docid) 'forward) - (message-goto-to))) - ((eq compose-type 'reply) ;; reply - (let* ((recipnum (+ (length (plist-get msg :to)) - (length (plist-get msg :cc)))) - (replyall (when (> recipnum 1) - (yes-or-no-p - (format "Reply to all ~%d recipients? " - (+ recipnum)))))) - ;; exact num depends on some more things - (when (mm/msg-compose (mm/msg-create-reply msg replyall) - (plist-get msg :docid) 'reply) - (message-goto-body)))) - ((eq compose-type 'draft) - (unless (member 'draft (plist-get msg :flags)) - (error "Cannot edit a non-draft message")) - (mm/edit-draft (plist-get msg :docid) (plist-get msg :path))) - - (t (error "unexpected type %S in compose handler" compose-type)))) - (defun mm/msg-save-to-sent () "Move the message in this buffer to the sent folder. This is meant to be called from message mode's `message-sent-hook'." (unless mm/sent-folder (error "mm/sent-folder not set")) - (when mm/mm-msg ;; only if we are mm - (let ((docid (gethash (buffer-file-name) mm/path-docid-map))) + (let ((docid (gethash (buffer-file-name) mm/path-docid-map))) (unless docid (error "unknown message (%S)" (buffer-file-name))) ;; ok, all seems well, well move the message to the sent-folder (mm/proc-move-msg docid mm/sent-folder "-T-D+S") @@ -409,67 +375,44 @@ edit buffer with the draft message" ;; mark the buffer as read-only, as its pointing at a non-existing file ;; now... (message "Message has been sent") - (setq buffer-read-only t)))) + (setq buffer-read-only t))) (defun mm/send-set-parent-flag () "Set the 'replied' flag on messages we replied to, and the 'passed' flag on message we have forwarded. -We do this by checking for our special header, either -`mm/reply-docid-header' or `mm/forward-docid-header'. Doing it this -way ensure that we know the parent-docid even when re-editing -drafts (alternatively, we could try to the 'parent' message -using "In-reply-to"/"References", but since that is not necessarily -accurate, doing it the way we do, is better. +If a message has a 'in-reply-to' header, it is considered a reply +to the message with the corresponding message id. If it does not +have an 'in-reply-to' header, but does have a 'references' header, +it is considered to be a forward message for the message +corresponding with the /last/ message-id in the references header. -TODO: remove this header again, before really sending. +Now, if the message has been determined to be either a forwarded +message or a reply, we instruct the server to update that message +with resp. the 'P' (passed) flag for a forwarded message, or the +'R' flag for a replied message. This is meant to be called from message mode's `message-sent-hook'." - ;; handle the replied-to message - (save-excursion - (goto-char (point-min)) - (let ((eoh (when (search-forward mail-header-separator nil t) - (point))) (reply-docid) (forward-docid)) - (when eoh ;; end-of-headers - (goto-char (point-min)) - (if (re-search-forward - (concat "^" mm/reply-docid-header ":[:blank:]*\\([0-9]+\\)") eoh t) - (setq reply-docid (string-to-int (match-string 1))) - (when (re-search-forward - (concat "^" mm/forward-docid-header ":[:blank:]*\\([0-9]+\\)") eoh t) - (setq forward-docid (string-to-int (match-string 1)))))) + (let ((in-reply-to (message-fetch-field "in-reply-to")) + (forwarded-from) + (references (message-fetch-field "references"))) + (unless in-reply-to + (when references + (with-temp-buffer ;; inspired by `message-shorten-references'. + (insert references) + (goto-char (point-min)) + (let ((refs)) + (while (re-search-forward "<[^ <]+@[^ <]+>" nil t) + (push (match-string 0) refs)) + (setq forwarded-from (last refs)) + (message "refs: %S, forwarded-from %S" refs forwarded-from))))) - (when reply-docid (mm/proc-flag-msg reply-docid "+R")) - (when forward-docid (mm/proc-flag-msg forward-docid "+P"))))) - -(defun mm/edit-draft (docid path) - "Edit a draft message." - - (unless (file-readable-p path) (error "Cannot read %s" path)) - (find-file path) - (message-mode) - - ;; hook our functions up with sending of the message - (add-hook 'message-sent-hook 'mm/msg-save-to-sent nil t) - (add-hook 'message-sent-hook 'mm/send-set-parent-flag nil t) - - (message-goto-body)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; some interactive function - -(defun mm/compose-new () - "Create a draft message, and switch to an edit buffer with the -draft message." - (interactive) - (when (mm/msg-compose (mm/msg-create-new)) - (message-goto-to))) + (when in-reply-to + (mm/proc-flag in-reply-to "+R")) + (when forwarded-from + (mm/proc-flag forwarded-from "+P")))) (provide 'mm-send) - - - diff --git a/toys/mm/mm-view.el b/toys/mm/mm-view.el index 418c6eb5..c45e30c1 100644 --- a/toys/mm/mm-view.el +++ b/toys/mm/mm-view.el @@ -207,9 +207,9 @@ or if not available, :body-html converted to text)." ;; misc (define-key map "w" 'mm/view-toggle-wrap-lines) (define-key map "h" 'mm/view-toggle-hide-quoted) - (define-key map "g" 'mm/view-refresh) - + (define-key map "R" 'mm/view-refresh) + ;; next 3 only warn user when attempt in the message view (define-key map "u" 'mm/view-unmark) (define-key map "U" 'mm/view-unmark) @@ -258,7 +258,7 @@ Seen; if the message is not New/Unread, do nothing." (docid (plist-get mm/current-msg :docid))) ;; is it a new message? (when (or (member 'unread flags) (member 'new flags)) - (mm/proc-flag-msg docid "+S-u-N"))))) + (mm/proc-flag docid "+S-u-N"))))) (defvar mm/link-map nil @@ -272,7 +272,7 @@ removing '^M' etc." ;; remove the stupid CRs (goto-char (point-min)) - (while (search-forward " \\| " nil t) + (while (re-search-forward " \\| " nil t) (replace-match "" nil t)) ;; give the footer a different color... diff --git a/toys/mm/mm.el b/toys/mm/mm.el index dc211826..b98378fd 100644 --- a/toys/mm/mm.el +++ b/toys/mm/mm.el @@ -347,7 +347,7 @@ be sure it no longer matches)." (defun mm/search-drafts () "Jump to your Drafts folder (as specified in `mm/draft-folder')." (interactive) - (mm/hdrs-search (concat "maildir:" mm/drafts-folder " OR ;; flag:draft"))) + (mm/hdrs-search (concat "maildir:" mm/drafts-folder " OR flag:draft"))) (defun mm/search-unread () "List all your unread messages."