113 lines
3.9 KiB
EmacsLisp
113 lines
3.9 KiB
EmacsLisp
|
;;; db-mail.el --- Utility Functions for sending mail -*- lexical-binding: t -*-
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(require 'cl-lib)
|
||
|
|
(require 'cl-macs)
|
||
|
|
(require 'mail-extr)
|
||
|
|
(require 'epg)
|
||
|
|
(require 'mml-sec)
|
||
|
|
|
||
|
|
(defun db/public-key (address &optional method)
|
||
|
|
"Return valid public keys for ADDRESS and given METHOD.
|
||
|
|
|
||
|
|
METHOD can be \"smime\" or \"pgpmime\"; defaults to \"pgpmime\".
|
||
|
|
ADDRESS is a string containing exactly one email address."
|
||
|
|
(check-type address string)
|
||
|
|
(unless method (setq method "pgpmime"))
|
||
|
|
(epg-list-keys (epg-make-context
|
||
|
|
(cond
|
||
|
|
((string= method "smime")
|
||
|
|
'CMS)
|
||
|
|
((string= method "pgpmime")
|
||
|
|
'OpenPGP)
|
||
|
|
(t (error "Unknown method %s" method))))
|
||
|
|
address))
|
||
|
|
|
||
|
|
(defun db/encryption-possible-p (recipients method)
|
||
|
|
"Check whether sending encrypted emails to all RECIPIENTS is possible.
|
||
|
|
|
||
|
|
METHOD specifies the encrypt method used. Can be either
|
||
|
|
\"smime\" or \"pgpmime\"."
|
||
|
|
(cl-every (lambda (recipient)
|
||
|
|
(not (null (db/public-key recipient method))))
|
||
|
|
recipients))
|
||
|
|
|
||
|
|
(defun db/message-recipients ()
|
||
|
|
"Return all recipients of the email in the current buffer."
|
||
|
|
(cl-mapcan (lambda (field)
|
||
|
|
(let ((field-value (message-field-value field)))
|
||
|
|
(when field-value
|
||
|
|
(mapcar #'cadr
|
||
|
|
(mail-extract-address-components field-value t)))))
|
||
|
|
(list "to" "cc" "bcc")))
|
||
|
|
|
||
|
|
(defun db/signencrypt-message-when-possible ()
|
||
|
|
"Add mml markers for signing and encryption of an email if possible."
|
||
|
|
(interactive)
|
||
|
|
(when (eq major-mode 'message-mode)
|
||
|
|
(let ((from (message-field-value "from")))
|
||
|
|
(when from
|
||
|
|
(let ((methods (if (string-match "@tu-dresden\.de>" from)
|
||
|
|
(list "smime" "pgpmime")
|
||
|
|
(list "pgpmime")))
|
||
|
|
(recipients (db/message-recipients)))
|
||
|
|
|
||
|
|
;; if there is no recipient, encrypt with default method
|
||
|
|
(if (null recipients)
|
||
|
|
(mml-secure-message (cl-first methods) 'signencrypt)
|
||
|
|
|
||
|
|
;; go through available keys
|
||
|
|
(let ((available-method
|
||
|
|
(cl-find-if (lambda (method)
|
||
|
|
(db/encryption-possible-p recipients method))
|
||
|
|
methods)))
|
||
|
|
|
||
|
|
(if available-method
|
||
|
|
(mml-secure-message available-method 'signencrypt)
|
||
|
|
|
||
|
|
;; if nothing works, sign with default method
|
||
|
|
(mml-secure-message (cl-first methods) 'sign)))))))))
|
||
|
|
|
||
|
|
(defun db/gnus-save-newsrc-with-whitespace-1 ()
|
||
|
|
"Save ~/.newsrc.eld with extra whitespace."
|
||
|
|
;; http://ding.gnus.narkive.com/pq3Z8ZjQ/pretty-printing-newsrc-eld#post3
|
||
|
|
(gnus-message 5 "Adding whitespace to .newsrc.eld")
|
||
|
|
(save-excursion
|
||
|
|
(goto-char (point-min))
|
||
|
|
(while (re-search-forward "(\\\"\\| ((\\| (nn" nil t)
|
||
|
|
(replace-match "\n \\&" t))
|
||
|
|
(delete-trailing-whitespace)))
|
||
|
|
|
||
|
|
(defun db/gnus-summary-open-Link ()
|
||
|
|
"Open link named \"Link\" in current article."
|
||
|
|
(interactive)
|
||
|
|
(save-window-excursion
|
||
|
|
(save-mark-and-excursion
|
||
|
|
(save-restriction
|
||
|
|
(widen)
|
||
|
|
(let ((url nil))
|
||
|
|
(unless (eq major-mode 'gnus-article-mode)
|
||
|
|
(gnus-summary-select-article-buffer))
|
||
|
|
(goto-char (point-min))
|
||
|
|
(while (and (not url)
|
||
|
|
(search-forward "Link"))
|
||
|
|
(backward-char)
|
||
|
|
(setq url (get-text-property (point) 'shr-url)))
|
||
|
|
(when url
|
||
|
|
(browse-url url)))))))
|
||
|
|
|
||
|
|
(defun db/gnus-html-mime-part-to-org ()
|
||
|
|
"Convert current gnus article to org mode."
|
||
|
|
(interactive)
|
||
|
|
(let ((return-code (gnus-mime-pipe-part "pandoc -f html -t org")))
|
||
|
|
(unless (zerop return-code)
|
||
|
|
(error "Error in extracting text"))
|
||
|
|
(with-current-buffer "*Shell Command Output*"
|
||
|
|
(kill-ring-save (point-min) (point-max)))))
|
||
|
|
|
||
|
|
(provide 'db-mail)
|
||
|
|
;;; db-mail ends here
|