Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
689 lines (601 sloc) 24.9 KB
;;;_ , Gnus
(require 'cl))
(require 'use-package)
(push (expand-file-name "override/bbdb/lisp" user-emacs-directory)
(load "gnus-settings")
(require 'gnus)
(require 'starttls)
;; (require 'nnmairix)
(require 'message)
(require 'spam)
(require 'spam-report)
(require 'bbdb)
(require 'bbdb-gnus)
(require 'bbdb-message)
;; (gnus-compile)
(bbdb-initialize 'gnus 'message)
(defvar use-spam-filtering nil)
;; Override definition from spam.el to use async.el
(defun spam-spamassassin-register-with-sa-learn (articles spam
&optional unregister)
"Register articles with spamassassin's sa-learn as spam or non-spam."
(if (and use-spam-filtering articles)
(let ((action (if unregister spam-sa-learn-unregister-switch
(if spam spam-sa-learn-spam-switch
(summary-buffer-name (buffer-name)))
;; group the articles into mbox format
(dolist (article articles)
(let (article-string)
(with-current-buffer summary-buffer-name
(setq article-string (spam-get-article-as-string article)))
(when (stringp article-string)
;; mbox separator
(insert (concat "From nobody " (current-time-string) "\n"))
(insert article-string)
(insert "\n"))))
;; call sa-learn on all messages at the same time, and also report
;; them as SPAM to the Internet
`(lambda ()
(insert ,(buffer-substring-no-properties
(point-min) (point-max)))
(call-process-region (point-min) (point-max)
nil nil nil "--mbox"
,@(if spam-sa-learn-rebuild
(list action)
(list "--no-rebuild" action)))
(if ,spam
(call-process-region (point-min) (point-max)
,(executable-find "spamassassin-5.12")
nil nil nil "--mbox" "-r"))))
`(lambda (&optional ignore)
(message "Finished learning messsages as %s"
,(if spam "spam" "ham"))))))))
(defvar switch-to-gnus-unplugged nil)
(defvar switch-to-gnus-run nil)
(defvar ido-default-buffer-method)
(declare-function ido-visit-buffer "ido"))
(defun switch-to-gnus (&optional arg)
(interactive "P")
(let* ((alist '("\\`\\*unsent" "\\`\\*Summary" "\\`\\*Group"))
(catch 'found
(dolist (regexp alist)
(dolist (buf (buffer-list))
(if (string-match regexp (buffer-name buf))
(throw 'found buf)))))))
(if (and switch-to-gnus-run candidate)
(if (featurep 'ido)
(ido-visit-buffer candidate ido-default-buffer-method)
(switch-to-buffer candidate))
(if (string-match "Group" (buffer-name candidate))
(let ((switch-to-gnus-unplugged arg))
;; (gnus)
(gnus-group-list-groups gnus-activate-level)
(setq switch-to-gnus-run t)))))
(defun quickping (host)
(= 0 (call-process "ping" nil nil nil "-c1" "-W50" "-q" host)))
(use-package gnus-group
:defer t
(use-package fetchmail-ctl
(bind-key "v b" #'switch-to-fetchmail gnus-group-mode-map)
(bind-key "v o" #'start-fetchmail gnus-group-mode-map)
(bind-key "v d" #'shutdown-fetchmail gnus-group-mode-map)
(bind-key "v k" #'kick-fetchmail gnus-group-mode-map)
(bind-key "v p" #'fetchnews-post gnus-group-mode-map)))
(use-package gnus-sum
(bind-key "F" #'gnus-summary-wide-reply-with-original
(bind-key "F" #'gnus-article-wide-reply-with-original
(add-hook 'gnus-group-mode-hook 'gnus-topic-mode)
(add-hook 'gnus-group-mode-hook 'hl-line-mode)
(add-hook 'gnus-summary-mode-hook 'hl-line-mode)
(defun my-message-header-setup-hook ()
(message-remove-header "From")
(let ((gcc (message-field-value "Gcc")))
(when (or (null gcc)
(string-match "nnfolder\\+archive:" gcc))
(message-remove-header "Gcc")
(format "Gcc: %s"
(if (string-match "\\`list\\." (or gnus-newsgroup-name ""))
(add-hook 'message-header-setup-hook 'my-message-header-setup-hook)
(defadvice gnus-summary-resend-message-edit (after call-my-mhs-hook activate)
(defun my-gnus-summary-save-parts (&optional arg)
(interactive "P")
(let ((directory "~/Downloads"))
(message "Saving all MIME parts to %s..." directory)
(gnus-summary-save-parts ".*" directory arg)
(message "Saving all MIME parts to %s...done" directory)))
(bind-key "X m" 'my-gnus-summary-save-parts gnus-summary-mode-map)
(defvar gnus-agent-queue-mail))
(defun queue-message-if-not-connected ()
(set (make-local-variable 'gnus-agent-queue-mail)
(if (quickping "") t 'always)))
(add-hook 'message-send-hook 'queue-message-if-not-connected)
(defun kick-postfix-if-needed ()
(if (and (quickping "")
(= 0 (call-process "/usr/bin/sudo" nil nil nil
"/usr/libexec/postfix/master" "-t")))
(start-process "postfix" nil "/usr/bin/sudo"
"/usr/libexec/postfix/master" "-e" "60")))
(add-hook 'message-sent-hook 'kick-postfix-if-needed)
(add-hook 'message-sent-hook 'gnus-score-followup-thread)
(defun exit-gnus-on-exit ()
(if (and (fboundp 'gnus-group-exit)
(with-current-buffer (get-buffer "*Group*")
(let (gnus-interactive-exit)
(add-hook 'kill-emacs-hook 'exit-gnus-on-exit)
(defun switch-in-other-buffer (buf)
(when buf
(switch-to-buffer-other-window buf)))
(defun open-mail-logs ()
(loop initially (delete-other-windows)
with first = t
for log in (directory-files "~/Messages/" t "\\.log\\'")
for buf = (find-file-noselect log)
do (if first
(switch-to-buffer buf)
(setf first nil))
(switch-in-other-buffer buf))
(with-current-buffer buf
(goto-char (point-max)))))
(defun my-gnus-trash-article (arg)
(interactive "P")
(if (string-match "\\(drafts\\|queue\\|delayed\\)" gnus-newsgroup-name)
(gnus-summary-delete-article arg)
(gnus-summary-move-article arg "mail.trash")))
(define-key gnus-summary-mode-map [(meta ?q)] 'gnus-article-fill-long-lines)
(define-key gnus-summary-mode-map [?B delete] 'gnus-summary-delete-article)
(define-key gnus-summary-mode-map [?B backspace] 'my-gnus-trash-article)
(define-key gnus-article-mode-map [(meta ?q)] 'gnus-article-fill-long-lines)
(defface gnus-summary-expirable-face
'((((class color) (background dark))
(:foreground "grey50" :italic t :strike-through t))
(((class color) (background light))
(:foreground "grey55" :italic t :strike-through t)))
"Face used to highlight articles marked as expirable."
:group 'gnus-summary-visual)
(push '((eq mark gnus-expirable-mark) . gnus-summary-expirable-face)
(if window-system
gnus-sum-thread-tree-false-root ""
gnus-sum-thread-tree-single-indent ""
gnus-sum-thread-tree-root ""
gnus-sum-thread-tree-vertical "|"
gnus-sum-thread-tree-leaf-with-other "+-> "
gnus-sum-thread-tree-single-leaf "\\-> "
gnus-sum-thread-tree-indent " "))
(defsubst dot-gnus-tos (time)
"Convert TIME to a floating point number."
(+ (* (car time) 65536.0)
(cadr time)
(/ (or (car (cdr (cdr time))) 0) 1000000.0)))
(defun gnus-user-format-function-S (header)
"Return how much time it's been since something was sent."
(condition-case err
(let ((date (mail-header-date header)))
(if (> (length date) 0)
((then (dot-gnus-tos
(apply 'encode-time (parse-time-string date))))
(now (dot-gnus-tos (current-time)))
(diff (- now then))
((>= diff (* 86400.0 7.0 52.0))
(if (>= diff (* 86400.0 7.0 52.0 10.0))
(format "%3dY" (floor (/ diff (* 86400.0 7.0 52.0))))
(format "%3.1fY" (/ diff (* 86400.0 7.0 52.0)))))
((>= diff (* 86400.0 30.0))
(if (>= diff (* 86400.0 30.0 10.0))
(format "%3dM" (floor (/ diff (* 86400.0 30.0))))
(format "%3.1fM" (/ diff (* 86400.0 30.0)))))
((>= diff (* 86400.0 7.0))
(if (>= diff (* 86400.0 7.0 10.0))
(format "%3dw" (floor (/ diff (* 86400.0 7.0))))
(format "%3.1fw" (/ diff (* 86400.0 7.0)))))
((>= diff 86400.0)
(if (>= diff (* 86400.0 10.0))
(format "%3dd" (floor (/ diff 86400.0)))
(format "%3.1fd" (/ diff 86400.0))))
((>= diff 3600.0)
(if (>= diff (* 3600.0 10.0))
(format "%3dh" (floor (/ diff 3600.0)))
(format "%3.1fh" (/ diff 3600.0))))
((>= diff 60.0)
(if (>= diff (* 60.0 10.0))
(format "%3dm" (floor (/ diff 60.0)))
(format "%3.1fm" (/ diff 60.0))))
(format "%3ds" (floor diff)))))
(replace-regexp-in-string "\\.0" "" str)))
(concat (cond
((= 2 (length stripped)) " ")
((= 3 (length stripped)) " ")
(t ""))
(error " ")))
(defvar gnus-count-recipients-threshold 5
"*Number of recipients to consider as large.")
(defun gnus-user-format-function-r (header)
"Given a Gnus message header, returns priority mark.
Here are the meanings:
The first column represent my relationship to the To: field. It can be:
I didn't appear (and the letter had one recipient)
: I didn't appear (and the letter had more than one recipient)
< I was the sole recipient
+ I was among a few recipients
* There were many recipients
The second column represents the Cc: field:
. I wasn't mentioned, but one other was
: I wasn't mentioned, but others were
^ I was the only Cc mentioned
& I was among a few Cc recipients
% I was among many Cc recipients
These can combine in some ways to tell you at a glance how visible the message
>. Someone wrote to me and one other
& I was copied along with several other people
*: Mail to lots of people in both the To and Cc!"
(let* ((to (or (cdr (assoc 'To (mail-header-extra header))) ""))
(cc (or (cdr (assoc 'Cc (mail-header-extra header))) ""))
(to-len (length (split-string to "\\s-*,\\s-*")))
(cc-len (length (split-string cc "\\s-*,\\s-*")))
(to-char (cond )))
(cond ((string-match gnus-ignored-from-addresses to)
(cond ((= to-len 1)
(cond ((string= cc "") "< ")
((= cc-len 1) "<.")
(t "<:")))
((< to-len gnus-count-recipients-threshold)
(cond ((string= cc "") "+ ")
((= cc-len 1) "+.")
(t "+:")))
(cond ((string= cc "") "* ")
((= cc-len 1) "*.")
(t "*:")))))
((string-match gnus-ignored-from-addresses cc)
(cond ((= cc-len 1)
(cond ((= to-len 1) " ^")
(t ":^")))
((< cc-len gnus-count-recipients-threshold)
(cond ((= to-len 1) " &")
(t ":&")))
(cond ((= to-len 1) " %")
(t ":%")))))
(t " "))))
(use-package message-x)
;; (use-package message
;; :defer t
;; :config
;; (defun adjust-body-goto-location ()
;; (if (looking-at "^--")
;; (save-excursion (insert ?\n ?\n))
;; (when (re-search-forward "^-- $" nil t)
;; (goto-char (match-beginning 0))
;; (if (looking-back "\n\n")
;; (forward-line -2)
;; (save-excursion (insert ?\n ?\n ?\n))
;; (forward-line 1)))))
;; (advice-add 'message-goto-body :after #'adjust-body-goto-location))
(use-package gnus-dired
:commands gnus-dired-mode
(add-hook 'dired-mode-hook 'gnus-dired-mode))
(use-package my-gnus-score
:commands (my-gnus-score-groups my-gnus-score-followup)
(defun gnus-group-get-all-new-news (&optional arg)
(interactive "P")
(gnus-group-get-new-news 5)
(gnus-group-list-groups (or arg 4))
(gnus-group-list-groups (or arg 4))
(gnus-group-save-newsrc t))
(define-key gnus-group-mode-map [?v ?g] 'gnus-group-get-all-new-news))
(use-package gnus-demon
(defun gnus-demon-scan-news-2 ()
(when gnus-plugged
(let ((win (current-window-configuration))
(gnus-read-active-file nil)
(gnus-check-new-newsgroups nil)
(gnus-verbose 2)
(gnus-verbose-backends 5))
(when (gnus-alive-p)
(with-current-buffer gnus-group-buffer
(gnus-group-get-new-news gnus-activate-level))))
(set-window-configuration win)))))
;; (gnus-demon-add-handler 'gnus-demon-scan-news-2 5 2)
(defun save-gnus-newsrc ()
(if (and (fboundp 'gnus-group-exit)
(with-current-buffer (get-buffer "*Group*")
(gnus-demon-add-handler 'save-gnus-newsrc nil 1)
(gnus-demon-add-handler 'gnus-demon-close-connections nil 3)))
(defun activate-gnus ()
(unless (get-buffer "*Group*") (gnus)))
(use-package epa
:defer t
(defun epa--key-widget-value-create (widget)
(let* ((key (widget-get widget :value))
(primary-sub-key (car (last (epg-key-sub-key-list key) 3)))
(primary-user-id (car (epg-key-user-id-list key))))
(insert (format "%c "
(if (epg-sub-key-validity primary-sub-key)
(car (rassq (epg-sub-key-validity primary-sub-key)
? ))
(epg-sub-key-id primary-sub-key)
" "
(if primary-user-id
(if (stringp (epg-user-id-string primary-user-id))
(epg-user-id-string primary-user-id)
(epg-decode-dn (epg-user-id-string primary-user-id)))
(use-package nnir
(defun gnus-goto-article (message-id)
(gnus-summary-read-group "INBOX" 15 t)
(let ((nnir-imap-default-search-key "imap")
(concat "\\(\\(list\\.wg21\\|archive\\)\\.\\|"
(gnus-summary-refer-article message-id)))
(defvar gnus-query-history nil)
(defun gnus-query (query &optional arg)
(list (read-string (format "IMAP Query %s: "
(if current-prefix-arg "All" "Mail"))
(format-time-string "SENTSINCE %d-%b-%Y "
(time-subtract (current-time)
(days-to-time 90)))
(let ((nnir-imap-default-search-key "imap")
;; (nnir-ignored-newsgroups
;; (if arg
;; (concat (regexp-opt
;; '("archive"
;; "archive.emacs"
;; "list"
;; "list.bahai"
;; "list.boost"
;; "list.clang"
;; "list.emacs"
;; "list.isocpp"
;; "list.ledger"
;; "list.llvm"
;; "list.wg21"
;; "mail"
;; ""
;; "Drafts"
;; "Sent Messages"))
;; "\\'")
;; (concat "\\(\\(list\\|archive\\)\\.\\|"
;; "mail\\.\\(spam\\|save\\|trash\\|sent\\)\\)")))
nil (list (cons 'nnir-query-spec
(list (cons 'query query)
(cons 'criteria "")))
(cons 'nnir-group-spec
(list (list "nnimap:Local")))))))
(define-key global-map [(alt meta ?f)] 'gnus-query))
(use-package gnus-harvest
:load-path "lisp/gnus-harvest"
:commands gnus-harvest-install
:demand t
(if (featurep 'message-x)
(gnus-harvest-install 'message-x)
(use-package gnus-alias
:commands (gnus-alias-determine-identity
(if (featurep 'message-x)
(add-hook 'message-x-after-completion-functions
(define-key message-mode-map "\C-c\C-f\C-p" 'gnus-alias-select-identity)
(defsubst match-in-strings (re strs)
(cl-some (apply-partially #'string-match re) strs))
(defun my-gnus-alias-determine-identity ()
(let ((addrs
(with-current-buffer (gnus-copy-article-buffer)
(apply #'nconc
#'(lambda (x)
(split-string (or (gnus-fetch-field x) "") ","))
'("To" "Cc" "From" "Reply-To")))))))
((or (match-in-strings "johnw@gnu\\.org" addrs)
(match-in-strings "emacs-.*@gnu" addrs)
(string-match "\\(gnu\\|emacs\\)" gnus-newsgroup-name))
(gnus-alias-use-identity "Gnu"))
((or (match-in-strings "" addrs)
(match-in-strings "@baesystems\\.com" addrs)
(string-match "\\(brass\\|safe\\|riscv\\)" gnus-newsgroup-name))
(gnus-alias-use-identity "Gmail"))
((or (match-in-strings "johnw@newartisans\\.com" addrs)
(string-match "\\(haskell\\|coq\\|agda\\|idris\\|acl2\\)"
(gnus-alias-use-identity "NewArtisans"))
((match-in-strings "john\\.wiegley@baesystems\\.com" addrs)
(gnus-alias-use-identity "BAE"))
(add-hook 'message-setup-hook #'my-gnus-alias-determine-identity))
(defvar gnus-balloon-face-0)
(defvar gnus-balloon-face-1))
(use-package rs-gnus-summary
(defalias 'gnus-user-format-function-size
(setq gnus-balloon-face-0 'rs-gnus-balloon-0)
(setq gnus-balloon-face-1 'rs-gnus-balloon-1))
(use-package supercite
:commands sc-cite-original
(add-hook 'mail-citation-hook 'sc-cite-original)
(defun sc-remove-existing-signature ()
(goto-char (region-beginning))
(when (re-search-forward message-signature-separator (region-end) t)
(delete-region (match-beginning 0) (region-end)))))
(add-hook 'mail-citation-hook 'sc-remove-existing-signature))
(defun sc-fill-if-different (&optional prefix)
"Fill the region bounded by `sc-fill-begin' and point.
Only fill if optional PREFIX is different than
`sc-fill-line-prefix'. If `sc-auto-fill-region-p' is nil, do not
fill region. If PREFIX is not supplied, initialize fill
variables. This is useful for a regi `begin' frame-entry."
(if (not prefix)
(setq sc-fill-line-prefix ""
sc-fill-begin (line-beginning-position))
(if (and sc-auto-fill-region-p
(not (string= prefix sc-fill-line-prefix)))
(let ((fill-prefix sc-fill-line-prefix))
(unless (or (string= fill-prefix "")
(goto-char sc-fill-begin)
(or (looking-at ">+ +")
(< (length
(buffer-substring (point)
(fill-region sc-fill-begin (line-beginning-position)))
(setq sc-fill-line-prefix prefix
sc-fill-begin (line-beginning-position)))))
(defun gnus-article-get-urls-region (min max)
"Return a list of urls found in the region between MIN and MAX"
(let (url-list)
(narrow-to-region min max)
(goto-char (point-min))
(while (re-search-forward gnus-button-url-regexp nil t)
(let ((match-string (match-string-no-properties 0)))
(if (and (not (equal (substring match-string 0 4) "file"))
(not (member match-string url-list)))
(setq url-list (cons match-string url-list)))))))
(defun gnus-article-get-current-urls ()
"Return a list of the urls found in the current `gnus-article-buffer'"
(let (url-list)
(with-current-buffer gnus-article-buffer
(setq url-list
(gnus-article-get-urls-region (point-min) (point-max))))
(defun gnus-article-browse-urls ()
"Visit a URL from the `gnus-article-buffer' by showing a
buffer with the list of URLs found with the `gnus-button-url-regexp'."
(gnus-configure-windows 'article)
(gnus-summary-select-article nil nil 'pseudo)
(let ((temp-buffer (generate-new-buffer " *Article URLS*"))
(urls (gnus-article-get-current-urls))
(this-window (selected-window))
(browse-window (get-buffer-window gnus-article-buffer))
(count 0))
(with-current-buffer temp-buffer
(mapc (lambda (string)
(insert (format "\t%d: %s\n" count string))
(setq count (1+ count))) urls)
(pop-to-buffer temp-buffer)
(setq count
(char-to-string (if (fboundp
(kill-buffer temp-buffer)))
(if browse-window
(progn (select-window browse-window)
(browse-url (nth count urls)))))
(select-window this-window)))
(use-package browse-url
:commands browse-url
(define-key gnus-summary-mode-map [(control ?c) (control ?o)]
(define-key gnus-article-mode-map [(control ?c) (control ?o)]
(use-package mml
:defer t
(defvar mml-signing-attachment nil)
(defun mml-sign-attached-file (file &optional type description disposition)
(unless (or mml-signing-attachment
(null current-prefix-arg))
(let ((signature
(expand-file-name (concat (file-name-nondirectory file) ".sig")
(mml-signing-attachment t))
(message "Signing %s..." file)
(if t
(call-process epg-gpg-program file nil nil
"--output" signature "--detach-sign" file)
(with-temp-file signature
(setq buffer-file-coding-system 'raw-text-unix)
(call-process epg-gpg-program file t nil "--detach-sign")))
(message "Signing %s...done" file)
(mml-attach-file signature))))
(advice-add 'mml-attach-file :after #'mml-sign-attached-file))
(use-package nnreddit
:load-path "site-lisp/nnreddit")
(provide 'dot-gnus)
;; Local Variables:
;; mode: emacs-lisp
;; outline-regexp: "^;;;_\\([,. ]+\\)"
;; End:
;;; dot-gnus.el ends here
Something went wrong with that request. Please try again.