You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

365 lines
15 KiB

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

This file contains ambiguous Unicode characters that may be confused with others in your current locale. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to highlight these characters.

;;; db-mail.el --- Utility Functions for sending mail -*- lexical-binding: t -*-
;;; Commentary:
;; This package consists mostly of utility functions for sending and editing
;; mail and extending Gnus in the way I like it. However, the most important
;; feature of is an abstract way to hande remote mail accounts. Theses are
;; stored in the variable `db/mail-accounts and consist of various entries
;; denoting how to read mail via IMAP (POP not supported) and how to send mail
;; via SMTP (server, port, protocol, …). Based on the entries in this variable,
;; appropriate settings of `gnus-secondary-select-methods are derived
;; automatically by the custom setter of `db/mail-accounts. Then when inside
;; Gnus, the mail can be read without further configuration. Note that when the
;; "IMAP address" of an entry in `db/mail-accounts is empty, it will not be
;; included as an IMAP account in `gnus-secondary-select-methods. This lets
;; you specify mail accounts that can be used for sending mail, but that are
;; read not directly via IMAP, but by other means (POP, offlineimap, …).
;; When sending mail, `db/mail-accounts is used to determine settings of the
;; relevant variables from `smtpmail based on the current value of the "From: "
;; header entry in the mail. If this header entry is set correctly, then
;; `db/smtpmail-send-it will set these variables automatically. To make this
;; work, however, two things have to be done:
;; - Ensure that the "From: " header is set correctly. In Gnus this can be done
;; by configuring `gnus-posting-style accordingly.
;; - Make sure `db/smtpmail-send-it is called when sending mail. For this set
;; the value `send-mail-function to `db/smtpmail-send-it.
;; All this functionality is provided under "Mail related customizations". The
;; other headlines provide the aforementioned utility functions.
;;; Code:
(require 'subr-x)
(require 'cl-lib)
(require 'cl-macs)
(require 'mail-extr)
(require 'epg)
(require 'mml-sec)
(require 'gnus)
(require 'gnus-start)
(require 'smtpmail) ; to have the globals bound below by let
(require 'message)
(require 'db-customize)
(declare-function gnus-summary-select-article-buffer "gnus-sum")
(declare-function gnus-mime-pipe-part "gnus-art")
;; Mail related customizations
;; See definition of `db/mail-accounts below, sorry for the scatter …
(defsubst db/mail-accounts--mail-address (account)
"Extract account mail address from ACCOUNT.
ACCOUNT must be a valid element of `db/mail-accounts."
(nth 0 account))
(defsubst db/mail-accounts--name (account)
"Extract account name from ACCOUNT.
ACCOUNT must be a valid element of `db/mail-accounts."
(nth 1 account))
(defsubst db/mail-accounts--imap-address (account)
"Extract account IMAP address from ACCOUNT.
ACCOUNT must be a valid element of `db/mail-accounts."
(nth 2 account))
(defsubst db/mail-accounts--smtp-server (account)
"Extract account SMTP server address from ACCOUNT.
ACCOUNT must be a valid element of `db/mail-accounts."
(nth 3 account))
(defsubst db/mail-accounts--smtp-stream-type (account)
"Extract account SMTP stream type from ACCOUNT.
ACCOUNT must be a valid element of `db/mail-accounts."
(nth 4 account))
(defsubst db/mail-accounts--smtp-service-port (account)
"Extract account SMTP port from ACCOUNT.
ACCOUNT must be a valid element of `db/mail-accounts."
(nth 5 account))
(defsubst db/mail-accounts--smtp-user (account)
"Extract account SMTP user from ACCOUNT.
ACCOUNT must be a valid element of `db/mail-accounts."
(nth 6 account))
(defun db/-set-gnus-secondary-select-methods (other-gnus-accounts remote-mail-accounts)
"Set `gnus-secondary-select-methods from OTHER-GNUS-ACCOUNTS and REMOTE-MAIL-ACCOUNTS.
The values of the latter two variables are usually those of
`db/other-gnus-accounts and `db/mail-accounts. If multiple
accounts exist with the same (cl-equalp) account name, only the
first will be added to `gnus-secondary-select-methods'."
(let ((select-methods (append other-gnus-accounts
;; Only add those remote accounts whose IMAP address is neither
;; `nil nor the empty string
(cl-remove-if #'null
(mapcar (lambda (account)
(let ((account-name (db/mail-accounts--name account))
(account-address (db/mail-accounts--imap-address account)))
(when (and account-address
(stringp account-address)
(< 0 (length account-address)))
`(nnimap ,account-name
(nnimap-address ,account-address)
(nnimap-stream starttls)
(nnimap-inbox "INBOX")))))
(setq gnus-secondary-select-methods
(cl-remove-duplicates select-methods
:key #'cl-second ; account name is second element
:test #'cl-equalp))))
;; Let's make the byte-compiler happy
(defvar gnus-posting-styles)
(defvar bbdb-user-mail-address-re)
(defvar message-dont-reply-to-names)
(defvar gnus-ignored-from-addresses)
(defun db/mail-accounts--set-value (symbol value)
"Set SYMBOL to VALUE, as needed for `db/mail-accounts."
(cl-assert (eq symbol 'db/mail-accounts)
"Only use `db/mail-accounts--set-value for setting `db/mail-accounts.")
(set-default symbol value)
;; Set `gnus-secondary-select-methods
;; Dont complain if `db/other-gnus-accounts is not defined yet
(and (boundp 'db/other-gnus-accounts) db/other-gnus-accounts)
;; Set posting styles based on existing mail addresses
(setq gnus-posting-styles
(name ,user-full-name)
(address ,user-mail-address)
(signature-file "~/.signature")
("X-Jabber-ID" ,db/jabber-id)))
(mapcar (lambda (account)
(let ((account-name (db/mail-accounts--name account))
(account-address (db/mail-accounts--mail-address account)))
`(,(concat account-name ":")
(name ,user-full-name)
(address ,account-address)
(signature-file "~/.signature")
("X-Jabber-ID" ,db/jabber-id))))
;; Update some variables
(setq bbdb-user-mail-address-re (regexp-opt (mapcar #'car value) 'words)
message-dont-reply-to-names (regexp-opt (mapcar #'car value) 'words)
gnus-ignored-from-addresses message-dont-reply-to-names))
(defcustom db/mail-accounts nil
"Configuration for remote email accounts.
This is a list of lists, where each such list specifies necessary
parameters for one particular email address. These addresses
will also be recognized when sending mail."
:group 'personal-settings
:type '(repeat
(string :tag "EMail Address")
(string :tag "Group Name")
(string :tag "IMAP Server Address (StartTLS)")
(string :tag "SMTP Server Address")
(choice :tag "SMTP Stream Type"
(const nil) (const starttls) (const plain) (const ssl))
(integer :tag "SMTP Service Port")
(string :tag "SMTP Login Name")))
:set #'db/mail-accounts--set-value)
(defun db/smtpmail-send-it ()
"Send prepared message in current buffer.
This function uses `message-smtpmail-send-it, but sets
`smtpmail-smtp-server, `smtpmail-stream-type,
`smtpmail-smtp-service, and `smtpmail-smtp-user based on the
entry of the \"From: \" header and the value of
(let* ((from (or (save-restriction
(mail-fetch-field "From"))
(address (cadr (mail-extract-address-components from)))
(account (assoc address db/mail-accounts)))
(message "Using address: %s" address)
(condition-case signal-data
(if account
(message "Sending with account for %s" address)
(let ((smtpmail-smtp-server (db/mail-accounts--smtp-server account))
(smtpmail-stream-type (db/mail-accounts--smtp-stream-type account))
(smtpmail-smtp-service (db/mail-accounts--smtp-service-port account))
(smtpmail-smtp-user (db/mail-accounts--smtp-user account)))
(cl-assert (cl-notany #'null (list smtpmail-smtp-server
"Settings %s for sending mail are not complete for account %s."
(if (yes-or-no-p "Sending with default account settings?")
(message "Sending aborted as requested by user.")))
;; in case of error, display the SMTP trace buffer if available
(error (when-let ((smtp-trace-buffer (get-buffer (format "*trace of SMTP session to %s*"
(shrink-window-if-larger-than-buffer (display-buffer smtp-trace-buffer)))
(signal (car signal-data) (cdr signal-data))))))
;; Setting other Gnus accounts
(defun db/other-gnus-accounts--set-value (symbol value)
"Set SYMBOL to VALUE as needed by `db/other-gnus-accounts"
(cl-assert (eq symbol 'db/other-gnus-accounts)
"Only use `db/other-gnus-accounts--set-value for setting `db/other-gnus-accounts.")
(set-default symbol value)
;; Dont complain if `db/mail-accounts is not defined yet.
(and (boundp 'db/mail-accounts) db/mail-accounts)))
(defcustom db/other-gnus-accounts nil
"Configuration for gnus accounts that are not IMAP/SMTP related.
Those are all accounts that are not derived from the entries in
`db/mail-accounts. The value of this variable should be a valid
value for `gnus-secondary-select-methods."
:group 'personal-settings
;; type definition for `gnus-select-method widget from gnus.el
:type '(repeat gnus-select-method)
:set #'db/other-gnus-accounts--set-value)
;; Functions related to email encryption
(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."
(cl-check-type address string)
(unless method (setq method "pgpmime"))
(epg-list-keys (epg-make-context
((string= method "smime")
((string= method "pgpmime")
(t (error "Unknown method %s" method))))
(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))))
(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."
(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))
(if available-method
(mml-secure-message available-method 'signencrypt)
;; if nothing works, sign with default method
(mml-secure-message (cl-first methods) 'sign)))))))))
;; Gnus utility functions
(defun db/gnus-save-newsrc-with-whitespace-1 ()
"Save ~/.newsrc.eld with extra whitespace."
(gnus-message 5 "Adding whitespace to .newsrc.eld")
(goto-char (point-min))
(while (re-search-forward "(\\\"\\| ((\\| (nn" nil t)
(replace-match "\n \\&" t))
(defun db/gnus-summary-open-Link ()
"Open link named \"Link\" in current article."
(let ((url nil))
(unless (eq major-mode 'gnus-article-mode)
(goto-char (point-min))
(while (and (not url)
(search-forward "Link"))
(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."
(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)))))
(defun db/gnus-demon-scan-news-on-level-2 ()
"Scan for news in Gnus on level 2."
;; from
(let ((win (current-window-configuration))
(gnus-read-active-file 'some)
(gnus-check-new-newsgroups nil)
(level 2))
(when (gnus-alive-p)
(with-current-buffer gnus-group-buffer
(gnus-group-get-new-news level))))
(set-window-configuration win)))))
(provide 'db-mail)
;;; db-mail ends here