1178 lines
52 KiB
EmacsLisp
1178 lines
52 KiB
EmacsLisp
;;; nndiscourse.el --- Gnus backend for Discourse -*- lexical-binding: t; coding: utf-8 -*-
|
|
|
|
;; Copyright (C) 2019 The Authors of nndiscourse.el
|
|
|
|
;; Authors: dickmao <github id: dickmao>
|
|
;; Version: 0.1.0
|
|
;; Keywords: news
|
|
;; URL: https://github.com/dickmao/nndiscourse
|
|
;; Package-Requires: ((emacs "25.1") (dash "2.18.1") (anaphora "1.0.4") (rbenv "0.0.3") (json-rpc "0.0.1"))
|
|
|
|
;; This file is NOT part of GNU Emacs.
|
|
|
|
;; This program 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.
|
|
|
|
;; This program 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 nndiscourse.el. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; A Gnus backend for Discourse.
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile (require 'cl-lib)
|
|
(cl-assert (fboundp 'libxml-parse-html-region) nil
|
|
"nndiscourse requires emacs built with libxml support"))
|
|
(require 'nnoo)
|
|
(require 'gnus)
|
|
(require 'gnus-start)
|
|
(require 'gnus-art)
|
|
(require 'gnus-sum)
|
|
(require 'gnus-msg)
|
|
(require 'gnus-cite)
|
|
(require 'gnus-srvr)
|
|
(require 'gnus-cache)
|
|
(require 'gnus-bcklg)
|
|
(require 'gnus-score)
|
|
(require 'mm-url)
|
|
(require 'cl-lib)
|
|
(require 'json)
|
|
(require 'subr-x)
|
|
(require 'dash)
|
|
(require 'anaphora)
|
|
(require 'json-rpc)
|
|
(require 'rbenv)
|
|
|
|
(nnoo-declare nndiscourse)
|
|
|
|
(nnoo-define-basics nndiscourse)
|
|
|
|
(defvoo nndiscourse-scheme "https"
|
|
"URI scheme for address.")
|
|
|
|
(defcustom nndiscourse-test-dir nil
|
|
"Test bundler install from here (see Makefile)."
|
|
:type 'directory
|
|
:group 'nndiscourse)
|
|
|
|
(defcustom nndiscourse-render-post t
|
|
"If non-nil, follow link upon `gnus-summary-select-article'.
|
|
Otherwise, just display link."
|
|
:type 'boolean
|
|
:group 'nndiscourse)
|
|
|
|
(defcustom nndiscourse-public-keyfile (expand-file-name "~/.ssh/id_rsa.pub")
|
|
"Location of rsa private key."
|
|
:type '(file :must-match t)
|
|
:group 'nndiscourse)
|
|
|
|
(defcustom nndiscourse-localhost "127.0.0.1"
|
|
"Some users keep their browser in a separate domain."
|
|
:type 'string
|
|
:group 'nndiscourse)
|
|
|
|
(defvoo nndiscourse-status-string "" "Out-of-band message.")
|
|
|
|
(defvar nndiscourse-by-server-hashtb (gnus-make-hashtable))
|
|
|
|
(defsubst nndiscourse--gethash (string hashtable &optional dflt)
|
|
"Get corresponding value of STRING from HASHTABLE, or DFLT if undefined.
|
|
Starting in emacs-src commit c1b63af, Gnus moved from obarrays to normal hashtables."
|
|
(unless (stringp string)
|
|
(setq string (format "%s" string)))
|
|
(if (fboundp 'gnus-gethash)
|
|
(let ((sym (intern-soft string hashtable)))
|
|
(if (or (null sym) (not (boundp sym))) dflt (symbol-value sym)))
|
|
(gethash string hashtable dflt)))
|
|
|
|
(defmacro nndiscourse--sethash (string value hashtable)
|
|
"Set corresponding value of STRING to VALUE in HASHTABLE.
|
|
Starting in emacs-src commit c1b63af, Gnus moved from obarrays to normal hashtables."
|
|
(declare (indent defun))
|
|
`(,(if (fboundp 'gnus-sethash)
|
|
'gnus-sethash
|
|
'puthash)
|
|
(format "%s" ,string) ,value ,hashtable))
|
|
|
|
(defmacro nndiscourse-by-server (server key)
|
|
"Get generalized variable for SERVER value of KEY.
|
|
Thought I could use macros here to setf it."
|
|
`(let ((foo (nndiscourse--gethash ,server nndiscourse-by-server-hashtb)))
|
|
(alist-get ,key foo)))
|
|
|
|
(defun nndiscourse-obarrayp (obj)
|
|
"Return t if OBJ is an obarray. `obarrayp' did not exist in emacs-25."
|
|
(and (vectorp obj) (< 0 (length obj))))
|
|
|
|
(defun nndiscourse-by-server-initial ()
|
|
"Ensure deep copy of seed values for `nndiscourse-by-server'."
|
|
(mapcar (lambda (x) (cons (car x)
|
|
(if (nndiscourse-obarrayp (cdr x)) (copy-sequence (cdr x))
|
|
(if (hash-table-p (cdr x))
|
|
(copy-hash-table (cdr x))
|
|
(cdr x)))))
|
|
`((:last-id . nil)
|
|
(:last-scan-time . ,(- (truncate (float-time)) 100))
|
|
(:headers-hashtb . ,(gnus-make-hashtable))
|
|
(:refs-hashtb . ,(gnus-make-hashtable))
|
|
(:categories-hashtb . ,(gnus-make-hashtable)))))
|
|
|
|
(defmacro nndiscourse--callback (result &optional callback)
|
|
"Set RESULT to return value of CALLBACK."
|
|
`(cl-function (lambda (&rest args &key data &allow-other-keys)
|
|
(setq ,result (if ,callback
|
|
(apply ,callback args)
|
|
data)))))
|
|
|
|
(cl-defstruct (nndiscourse-proc-info)
|
|
"port and elisp process"
|
|
port process)
|
|
|
|
(defvar nndiscourse-processes nil
|
|
"Association list of ( server-name-qua-url . nndiscourse-proc-info ).")
|
|
|
|
(defun nndiscourse-good-server (server)
|
|
"SERVER needs to be a non-zero length string."
|
|
(or (and (stringp server) (not (zerop (length server)))
|
|
(prog1 t
|
|
(unless (nndiscourse--gethash server nndiscourse-by-server-hashtb)
|
|
(nndiscourse--sethash server
|
|
(nndiscourse-by-server-initial)
|
|
nndiscourse-by-server-hashtb))))
|
|
(prog1 nil (backtrace))))
|
|
|
|
(defsubst nndiscourse--replace-hash (string func hashtable)
|
|
"Set value of STRING to FUNC applied to existing STRING value in HASHTABLE.
|
|
|
|
Starting in emacs-src commit c1b63af, Gnus moved from obarrays to normal hashtables."
|
|
(declare (indent defun))
|
|
(unless (stringp string)
|
|
(setq string (prin1-to-string string)))
|
|
(let* ((capture (nndiscourse--gethash string hashtable))
|
|
(replace-with (funcall func capture)))
|
|
(if (fboundp 'gnus-sethash)
|
|
(set (intern string hashtable) replace-with)
|
|
(puthash string replace-with hashtable))))
|
|
|
|
(defmacro nndiscourse--maphash (func table)
|
|
"Map FUNC taking key and value over TABLE, return nil.
|
|
|
|
Starting in emacs-src commit c1b63af, Gnus moved from obarrays to normal hashtables."
|
|
(declare (indent nil))
|
|
(let ((workaround 'gnus-gethash-safe))
|
|
`(,(if (fboundp 'gnus-gethash-safe)
|
|
'mapatoms
|
|
'maphash)
|
|
,(if (fboundp 'gnus-gethash-safe)
|
|
`(lambda (k) (funcall
|
|
(apply-partially
|
|
,func
|
|
(symbol-name k) (,workaround k ,table))))
|
|
func)
|
|
,table)))
|
|
|
|
(defvar nndiscourse-summary-voting-map
|
|
(let ((map (make-sparse-keymap)))
|
|
map)
|
|
"Voting map.")
|
|
|
|
(defvar nndiscourse-summary-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map "r" 'gnus-summary-followup)
|
|
(define-prefix-command 'nndiscourse-summary-voting-map)
|
|
(define-key map "R" 'nndiscourse-summary-voting-map)
|
|
(define-key nndiscourse-summary-voting-map "0" 'nndiscourse-novote)
|
|
(define-key nndiscourse-summary-voting-map "-" 'nndiscourse-downvote)
|
|
(define-key nndiscourse-summary-voting-map "=" 'nndiscourse-upvote)
|
|
(define-key nndiscourse-summary-voting-map "+" 'nndiscourse-upvote)
|
|
map))
|
|
|
|
(defvar nndiscourse-article-mode-map
|
|
(copy-keymap nndiscourse-summary-mode-map)) ;; how does Gnus do this?
|
|
|
|
(define-minor-mode nndiscourse-article-mode
|
|
"Minor mode for nndiscourse articles.
|
|
Disallow `gnus-article-reply-with-original'.
|
|
|
|
\\{gnus-article-mode-map}"
|
|
:lighter " Discourse"
|
|
:keymap nndiscourse-article-mode-map)
|
|
|
|
(define-minor-mode nndiscourse-summary-mode
|
|
"Disallow \"reply\" commands in `gnus-summary-mode-map'.
|
|
|
|
\\{nndiscourse-summary-mode-map}"
|
|
:lighter " Discourse"
|
|
:keymap nndiscourse-summary-mode-map)
|
|
|
|
(defsubst nndiscourse-get-headers (server group)
|
|
"List headers for SERVER GROUP."
|
|
(nndiscourse--gethash group (nndiscourse-by-server server :headers-hashtb)))
|
|
|
|
(defun nndiscourse-set-headers (server group new-headers)
|
|
"Assign headers for SERVER GROUP to NEW-HEADERS."
|
|
(nndiscourse--sethash group new-headers (nndiscourse-by-server server :headers-hashtb)))
|
|
|
|
(defun nndiscourse-get-refs (server id)
|
|
"Amongst SERVER refs, return list of descending ancestors for ID."
|
|
(cl-loop for prev-id = id then cur-id
|
|
for cur-id = (nndiscourse--gethash prev-id (nndiscourse-by-server server :refs-hashtb))
|
|
until (not cur-id)
|
|
collect cur-id into rresult
|
|
finally return (nreverse rresult)))
|
|
|
|
(defun nndiscourse-set-ref (server id parent-id)
|
|
"Amongst SERVER refs, associate ID to PARENT-ID."
|
|
(nndiscourse--sethash id parent-id (nndiscourse-by-server server :refs-hashtb)))
|
|
|
|
(defun nndiscourse-get-category (server category-id)
|
|
"Amongst SERVER categories, return group for CATEGORY-ID."
|
|
(nndiscourse--gethash category-id (nndiscourse-by-server server :categories-hashtb)))
|
|
|
|
(defun nndiscourse-set-category (server category-id group)
|
|
"Amongst SERVER categories, associate CATEGORY-ID to GROUP."
|
|
(nndiscourse--sethash category-id group (nndiscourse-by-server server :categories-hashtb)))
|
|
|
|
(defmacro nndiscourse--with-mutex (mtx &rest body)
|
|
"If capable of threading, lock with MTX and execute BODY."
|
|
(declare (indent defun))
|
|
(if (fboundp 'with-mutex)
|
|
`(with-mutex ,mtx ,@body)
|
|
`(progn ,@body)))
|
|
|
|
(defvar nndiscourse--mutex-rpc-request (when (fboundp 'make-mutex)
|
|
(make-mutex "nndiscourse--mutex-rpc-request"))
|
|
"Only one jsonrpc output buffer, so avoid two requests using at the same time.")
|
|
|
|
(declare-function set-process-thread "process" t t) ;; emacs-25
|
|
|
|
(defun nndiscourse-rpc-request (server method &rest args)
|
|
"Make jsonrpc call to SERVER invoking METHOD ARGS.
|
|
|
|
nnreddit had just one jsonrpyc process using stdio pipe for IPC.
|
|
jsonrpyc could not assume HTTP.
|
|
|
|
The jimson library does assume HTTP, so we follow `json-rpc' SOP.
|
|
This means two processes, one jimson process, which we administer,
|
|
and one `json-rpc' network pipe which json-rpc.el administers.
|
|
|
|
Process stays the same, but the `json-rpc' connection (a cheap struct) gets
|
|
reinstantiated with every call.
|
|
|
|
Return response of METHOD ARGS of type `json-object-type' or nil if failure."
|
|
(when (and (nndiscourse-good-server server) (nndiscourse-server-opened server))
|
|
(condition-case err
|
|
(if-let ((port (nndiscourse-proc-info-port
|
|
(cdr (assoc server nndiscourse-processes))))
|
|
(connection (json-rpc-connect nndiscourse-localhost port))
|
|
(sock (json-rpc-process connection)))
|
|
(unwind-protect
|
|
(progn
|
|
(set-process-query-on-exit-flag sock nil)
|
|
(when (fboundp 'set-process-thread)
|
|
(set-process-thread sock nil))
|
|
(nndiscourse--with-mutex nndiscourse--mutex-rpc-request
|
|
(gnus-message 7 "nndiscourse-rpc-request: send %s %s" method
|
|
(mapconcat (lambda (s) (format "%s" s)) args " "))
|
|
(json-rpc connection method args)))
|
|
(json-rpc-close connection))
|
|
(error (prog1 nil
|
|
(gnus-message 3 "nndiscourse-rpc-request: could not connect to %s:%s"
|
|
nndiscourse-localhost port))))
|
|
(error (prog1 nil
|
|
(gnus-message 3 "nndiscourse-rpc-request: %s" (error-message-string err)))))))
|
|
|
|
(defsubst nndiscourse--gate (&optional group)
|
|
"Apply our minor modes only when the following conditions hold for GROUP."
|
|
(unless group
|
|
(setq group gnus-newsgroup-name))
|
|
(and (stringp group)
|
|
(listp (gnus-group-method group))
|
|
(eq 'nndiscourse (car (gnus-group-method group)))))
|
|
|
|
(deffoo nndiscourse-request-close ()
|
|
"Nnimap does nothing also."
|
|
t)
|
|
|
|
(deffoo nndiscourse-request-type (_group &optional _article)
|
|
'news)
|
|
|
|
(defsubst nndiscourse--server-buffer-name (server)
|
|
"Arbitrary proc buffer name for SERVER."
|
|
(when (nndiscourse-good-server server)
|
|
(format " *%s*" server)))
|
|
|
|
(defsubst nndiscourse--server-buffer (server &optional create)
|
|
"Get proc buffer for SERVER. Create if necessary if CREATE."
|
|
(when (nndiscourse-good-server server)
|
|
(let ((name (nndiscourse--server-buffer-name server)))
|
|
(if create
|
|
(get-buffer-create name)
|
|
(get-buffer name)))))
|
|
|
|
(deffoo nndiscourse-server-opened (&optional server)
|
|
(when (nndiscourse-good-server server)
|
|
(buffer-live-p (nndiscourse--server-buffer server))))
|
|
|
|
(deffoo nndiscourse-status-message (&optional server)
|
|
(when (nndiscourse-good-server server)
|
|
nndiscourse-status-string))
|
|
|
|
(defun nndiscourse--initialize ()
|
|
"Run `bundle install` if necessary."
|
|
(let ((default-directory
|
|
(expand-file-name "nndiscourse"
|
|
(or nndiscourse-test-dir
|
|
(file-name-directory
|
|
(or (locate-library "nndiscourse")
|
|
default-directory)))))
|
|
(bundle-exec (executable-find "bundle")))
|
|
(unless bundle-exec
|
|
(error "`nndiscourse--initialize': nndiscourse requires bundler"))
|
|
(unless (file-exists-p (expand-file-name "vendor"))
|
|
(let ((bundle-buffer (get-buffer-create "*nndiscourse: bundle install*")))
|
|
(if (zerop (apply #'call-process bundle-exec nil
|
|
(cons bundle-buffer (list t))
|
|
nil (split-string "install --deployment --without development")))
|
|
(kill-buffer bundle-buffer)
|
|
(switch-to-buffer bundle-buffer)
|
|
(error "`nndiscourse--initialize': bundle install failed"))))))
|
|
|
|
(deffoo nndiscourse-open-server (server &optional defs)
|
|
"Retrieve the Jimson process for SERVER.
|
|
|
|
I am counting on `gnus-check-server` in `gnus-read-active-file-1' in
|
|
`gnus-get-unread-articles' to open server upon install."
|
|
(when (nndiscourse-good-server server)
|
|
(or (nndiscourse-server-opened server)
|
|
(let ((original-global-rbenv-mode global-rbenv-mode))
|
|
(unless global-rbenv-mode
|
|
(let (rbenv-show-active-ruby-in-modeline)
|
|
(global-rbenv-mode)))
|
|
(unwind-protect
|
|
(progn
|
|
(when defs ;; defs should be non-nil when called from `gnus-open-server'
|
|
(nndiscourse--initialize))
|
|
(nnoo-change-server 'nndiscourse server defs)
|
|
(let* ((proc-buf (nndiscourse--server-buffer server t))
|
|
(proc (get-buffer-process proc-buf)))
|
|
(if (process-live-p proc)
|
|
proc
|
|
(let* ((free-port (with-temp-buffer
|
|
(let ((proc (make-network-process
|
|
:name "free-port"
|
|
:noquery t
|
|
:host nndiscourse-localhost
|
|
:buffer (current-buffer)
|
|
:server t
|
|
:stop t
|
|
:service t)))
|
|
(prog1 (process-contact proc :service)
|
|
(delete-process proc)))))
|
|
(ruby-command (split-string (format "%s exec thor cli:serve %s://%s -p %s"
|
|
(executable-find "bundle")
|
|
nndiscourse-scheme
|
|
server
|
|
free-port)))
|
|
(stderr-buffer (get-buffer-create (format " *%s-stderr*" server))))
|
|
(with-current-buffer stderr-buffer
|
|
(add-hook 'after-change-functions
|
|
(apply-partially #'nndiscourse--message-user server)
|
|
nil t))
|
|
(nndiscourse-register-process
|
|
free-port
|
|
(let ((default-directory
|
|
(expand-file-name "nndiscourse"
|
|
(or nndiscourse-test-dir
|
|
(file-name-directory
|
|
(or (locate-library "nndiscourse")
|
|
default-directory))))))
|
|
(let ((new-proc (make-process :name server
|
|
:buffer proc-buf
|
|
:command ruby-command
|
|
:noquery t
|
|
:sentinel #'nndiscourse-sentinel
|
|
:stderr stderr-buffer)))
|
|
(cl-loop repeat 10
|
|
until (condition-case nil
|
|
(prog1 t
|
|
(delete-process
|
|
(make-network-process :name "test-port"
|
|
:noquery t
|
|
:host nndiscourse-localhost
|
|
:service free-port
|
|
:buffer nil
|
|
:stop t)))
|
|
(file-error nil))
|
|
do (accept-process-output new-proc 0.3))
|
|
new-proc)))))))
|
|
(unless original-global-rbenv-mode
|
|
(global-rbenv-mode -1)))))))
|
|
|
|
(defun nndiscourse-alist-get (key alist &optional default remove testfn)
|
|
"Replicated library function for emacs-25.
|
|
|
|
Same argument meanings for KEY ALIST DEFAULT REMOVE and TESTFN."
|
|
(ignore remove)
|
|
(let ((x (if (not testfn)
|
|
(assq key alist)
|
|
(assoc key alist))))
|
|
(if x (cdr x) default)))
|
|
|
|
(gv-define-expander nndiscourse-alist-get
|
|
(lambda (do key alist &optional default remove testfn)
|
|
(macroexp-let2 macroexp-copyable-p k key
|
|
(gv-letplace (getter setter) alist
|
|
(macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
|
|
(assoc ,k ,getter)
|
|
(assq ,k ,getter))
|
|
(funcall do (if (null default) `(cdr ,p)
|
|
`(if ,p (cdr ,p) ,default))
|
|
(lambda (v)
|
|
(macroexp-let2 nil v v
|
|
(let ((set-exp
|
|
`(if ,p (setcdr ,p ,v)
|
|
,(funcall setter
|
|
`(cons (setq ,p (cons ,k ,v))
|
|
,getter)))))
|
|
`(progn
|
|
,(cond
|
|
((null remove) set-exp)
|
|
((or (eql v default)
|
|
(and (eq (car-safe v) 'quote)
|
|
(eq (car-safe default) 'quote)
|
|
(eql (cadr v) (cadr default))))
|
|
`(if ,p ,(funcall setter `(delq ,p ,getter))))
|
|
(t
|
|
`(cond
|
|
((not (eql ,default ,v)) ,set-exp)
|
|
(,p ,(funcall setter
|
|
`(delq ,p ,getter))))))
|
|
,v))))))))))
|
|
|
|
(defun nndiscourse-register-process (port proc)
|
|
"Register PORT and PROC with a server-name-qua-url.
|
|
Return PROC if success, nil otherwise."
|
|
(declare (indent defun))
|
|
(nndiscourse-deregister-process (process-name proc))
|
|
(if (process-live-p proc)
|
|
(prog1 proc
|
|
(gnus-message 5 "nndiscourse-register-process: registering %s"
|
|
(process-name proc))
|
|
(setf (nndiscourse-alist-get (process-name proc) nndiscourse-processes
|
|
nil nil #'equal)
|
|
(make-nndiscourse-proc-info :port port :process proc)))
|
|
(prog1 nil
|
|
(gnus-message 3 "`nndiscourse-register-process': dead process %s"
|
|
(process-name proc))
|
|
(nndiscourse-deregister-process (process-name proc)))))
|
|
|
|
(defun nndiscourse-deregister-process (server)
|
|
"Disavow any knowledge of SERVER's process."
|
|
(awhen (nndiscourse-alist-get server nndiscourse-processes nil nil #'equal)
|
|
(let ((proc (nndiscourse-proc-info-process it)))
|
|
(gnus-message 5 "`nndiscourse-deregister-process': deregistering %s %s pid=%s"
|
|
server (process-name proc) (process-id proc))
|
|
(delete-process proc)))
|
|
(setf (nndiscourse-alist-get server nndiscourse-processes nil nil #'equal) nil))
|
|
|
|
(deffoo nndiscourse-close-server (&optional server defs)
|
|
"Patterning after nnimap.el."
|
|
(when (nndiscourse-good-server server)
|
|
(nndiscourse-deregister-process server)
|
|
(awhen (nndiscourse--server-buffer server)
|
|
(kill-buffer it))
|
|
;; keep state in nndiscourse-by-server-hashtb?
|
|
(when (nnoo-change-server 'nndiscourse server defs)
|
|
(nnoo-close-server 'nndiscourse server))
|
|
t))
|
|
|
|
(deffoo nndiscourse-close-group (_group &optional server)
|
|
(nnoo-change-server 'nndiscourse server nil)
|
|
t)
|
|
|
|
(defmacro nndiscourse--with-group (server group &rest body)
|
|
"If `gnus-newsgroup-name' is null, recreate it based on SERVER.
|
|
Disambiguate GROUP if it's empty.
|
|
Then execute BODY."
|
|
(declare (debug (form &rest form))
|
|
(indent defun))
|
|
`(let* ((group (or ,group (gnus-group-real-name gnus-newsgroup-name)))
|
|
(gnus-newsgroup-name (or gnus-newsgroup-name
|
|
(gnus-group-full-name
|
|
group (cons 'nndiscourse (list server)))))
|
|
(server (or ,server (nth 1 (gnus-find-method-for-group gnus-newsgroup-name)))))
|
|
,@body))
|
|
|
|
(defsubst nndiscourse--first-article-number (server group)
|
|
"Get article-number qua id of first article of SERVER GROUP."
|
|
(plist-get (car (nndiscourse-get-headers server group)) :id))
|
|
|
|
(defsubst nndiscourse--last-article-number (server group)
|
|
"Get article-number qua id of last article of SERVER GROUP."
|
|
(plist-get (car (last (nndiscourse-get-headers server group))) :id))
|
|
|
|
(defun nndiscourse--get-header (server group article-number)
|
|
"Amongst SERVER GROUP headers, binary search ARTICLE-NUMBER."
|
|
(let ((headers (nndiscourse-get-headers server group)))
|
|
(cl-flet ((id-of (k) (plist-get (elt headers k) :id)))
|
|
(cl-do* ((x article-number)
|
|
(l 0 (if dir (1+ m) l))
|
|
(r (length headers) (if dir r m))
|
|
(m (/ (- r l) 2) (+ m (* (if dir 1 -1) (max 1 (/ (- r l) 2)))))
|
|
(dir (> x (id-of m)) (> x (id-of m))))
|
|
((or (<= (- r l) 1) (= x (id-of m)))
|
|
(and (< m (length headers)) (>= m 0) (= x (id-of m)) (elt headers m)))))))
|
|
|
|
(defun nndiscourse--massage (body)
|
|
"Precede each quoted line of BODY broken by `shr-fill-line' with '>'."
|
|
(with-temp-buffer
|
|
(insert body)
|
|
(mm-url-decode-entities)
|
|
(cl-loop initially (goto-char (point-min))
|
|
until (and (null (re-search-forward "\\(^>\\( .*?\\)\\)<p>" nil t))
|
|
(null (re-search-forward "\\(<p>\\s-*>\\( .*?\\)\\)<p>" nil t)))
|
|
do (let* ((start (match-beginning 1))
|
|
(end (match-end 1))
|
|
(matched (match-string 2)))
|
|
(perform-replace
|
|
".*"
|
|
(concat "<p>\n"
|
|
(with-temp-buffer
|
|
(insert matched)
|
|
(fill-region (point-min) (point-max))
|
|
(insert
|
|
(prog1
|
|
(cl-subseq (replace-regexp-in-string
|
|
"\n" "<br>\n> " (concat "\n" (buffer-string)))
|
|
5)
|
|
(erase-buffer)))
|
|
(buffer-string))
|
|
"\n")
|
|
nil t nil nil nil start end)))
|
|
(buffer-string)))
|
|
|
|
(defsubst nndiscourse--citation-wrap (author body)
|
|
"Cite AUTHOR using `gnus-message-cite-prefix-regexp' before displaying BODY.
|
|
|
|
Originally written by Paul Issartel."
|
|
(with-temp-buffer
|
|
(insert body)
|
|
(mm-url-remove-markup)
|
|
(mm-url-decode-entities)
|
|
(fill-region (point-min) (point-max))
|
|
(let* ((trimmed-1 (replace-regexp-in-string "\\(\\s-\\|\n\\)+$" "" (buffer-string)))
|
|
(trimmed (replace-regexp-in-string "^\\(\\s-\\|\n\\)+" "" trimmed-1)))
|
|
(concat author " wrote:<p>\n"
|
|
"<pre>\n"
|
|
(cl-subseq (replace-regexp-in-string "\n" "\n> " (concat "\n" trimmed)) 1)
|
|
"\n</pre><p>"))))
|
|
|
|
(defun nndiscourse-add-entry (hashtb e field)
|
|
"Add to HASHTB a lookup consisting of entry E's id to its FIELD."
|
|
(nndiscourse--sethash (plist-get e :id) (plist-get e field) hashtb))
|
|
|
|
(defsubst nndiscourse--summary-exit ()
|
|
"Call `gnus-summary-exit' without the hackery."
|
|
(remove-function (symbol-function 'gnus-summary-exit)
|
|
(symbol-function 'nndiscourse--score-pending))
|
|
(gnus-summary-exit)
|
|
(add-function :after (symbol-function 'gnus-summary-exit)
|
|
(symbol-function 'nndiscourse--score-pending)))
|
|
|
|
(deffoo nndiscourse-request-group-scan (group &optional server info)
|
|
"\\[gnus-group-get-new-news-this-group] from *Group* calls this."
|
|
(nndiscourse--with-group server group
|
|
(gnus-message 5 "nndiscourse-request-group-scan: scanning %s..." group)
|
|
(nndiscourse-request-scan nil server)
|
|
(gnus-get-unread-articles-in-group
|
|
(or info (gnus-get-info gnus-newsgroup-name))
|
|
(gnus-active (gnus-info-group info)))
|
|
(gnus-message 5 "nndiscourse-request-group-scan: scanning %s...done" group))
|
|
t)
|
|
|
|
;; gnus-group-select-group
|
|
;; gnus-group-read-group
|
|
;; gnus-summary-read-group
|
|
;; gnus-summary-read-group-1
|
|
;; gnus-summary-setup-buffer
|
|
;; sets gnus-newsgroup-name
|
|
;; gnus-select-newsgroup
|
|
;; gnus-request-group
|
|
;; nndiscourse-request-group
|
|
(deffoo nndiscourse-request-group (group &optional server _fast _info)
|
|
(nndiscourse--with-group server group
|
|
(let* ((num-headers (length (nndiscourse-get-headers server group)))
|
|
(status (format "211 %d %d %d %s" num-headers
|
|
(aif (nndiscourse--first-article-number server group) it 1)
|
|
(aif (nndiscourse--last-article-number server group) it 0)
|
|
group)))
|
|
(gnus-message 7 "nndiscourse-request-group: %s" status)
|
|
(nnheader-insert "%s\n" status))
|
|
t))
|
|
|
|
(defun nndiscourse--request-item (id server)
|
|
"Retrieve ID from SERVER as a property list."
|
|
(let* ((port (nndiscourse-proc-info-port (cdr (assoc server nndiscourse-processes))))
|
|
(conn (json-rpc-connect nndiscourse-localhost port))
|
|
(utf-decoder (lambda (x)
|
|
(decode-coding-string (with-temp-buffer
|
|
(set-buffer-multibyte nil)
|
|
(insert x)
|
|
(buffer-string))
|
|
'utf-8))))
|
|
(add-function :filter-return (symbol-function 'json-read-string) utf-decoder)
|
|
(unwind-protect
|
|
(condition-case err (json-rpc conn "get_post" id)
|
|
(error (gnus-message 3 "nndiscourse--request-item: %s" (error-message-string err))
|
|
nil))
|
|
(remove-function (symbol-function 'json-read-string) utf-decoder))))
|
|
|
|
(defun nndiscourse-get-categories (server)
|
|
"Query SERVER /categories.json."
|
|
(seq-filter (lambda (x) (eq json-false (plist-get x :read_restricted)))
|
|
(let ((cats (funcall #'nndiscourse-rpc-request server "categories")))
|
|
(when (seqp cats) cats))))
|
|
|
|
(cl-defun nndiscourse-get-topics (server slug &key (page 0))
|
|
"Query SERVER /c/SLUG/l/latest.json, optionally for PAGE."
|
|
(funcall #'nndiscourse-rpc-request server
|
|
"category_latest_topics"
|
|
:category_slug slug :page page))
|
|
|
|
(cl-defun nndiscourse-get-posts (server &key (before 0))
|
|
"Query SERVER /posts.json for posts before BEFORE."
|
|
(plist-get (let ((result (funcall #'nndiscourse-rpc-request server
|
|
"posts" :before before)))
|
|
(when (listp result) result))
|
|
:latest_posts))
|
|
|
|
(defun nndiscourse--number-to-header (server group topic-id post-number)
|
|
"O(n) search for SERVER GROUP TOPIC-ID POST-NUMBER in headers."
|
|
(declare (indent defun))
|
|
(-when-let* ((headers (nndiscourse-get-headers server group))
|
|
(found (seq-position
|
|
headers (cons topic-id post-number)
|
|
(lambda (plst loc)
|
|
(cl-destructuring-bind (topic-id* . post-number*) loc
|
|
(and (= topic-id* (plist-get plst :topic_id))
|
|
(= post-number* (plist-get plst :post_number))))))))
|
|
(elt headers found)))
|
|
|
|
(defun nndiscourse--earliest-header (server group topic-id)
|
|
"O(n) search for first header satisfying SERVER GROUP TOPIC-ID."
|
|
(declare (indent defun))
|
|
(-when-let* ((headers (nndiscourse-get-headers server group)))
|
|
(seq-find (lambda (plst) (= topic-id (plist-get plst :topic_id)))
|
|
headers)))
|
|
|
|
(defsubst nndiscourse-hash-count (table-or-obarray)
|
|
"Return number items in TABLE-OR-OBARRAY."
|
|
(let ((result 0))
|
|
(nndiscourse--maphash (lambda (&rest _args) (cl-incf result)) table-or-obarray)
|
|
result))
|
|
|
|
(defsubst nndiscourse-hash-values (table-or-obarray)
|
|
"Return right hand sides in TABLE-OR-OBARRAY."
|
|
(let (result)
|
|
(nndiscourse--maphash (lambda (_key value) (push value result)) table-or-obarray)
|
|
result))
|
|
|
|
(defsubst nndiscourse-hash-keys (table-or-obarray)
|
|
"Return left hand sides in TABLE-OR-OBARRAY."
|
|
(let (result)
|
|
(nndiscourse--maphash (lambda (key _value) (push key result)) table-or-obarray)
|
|
result))
|
|
|
|
(defun nndiscourse--incoming (server)
|
|
"Drink from the SERVER firehose."
|
|
(interactive)
|
|
(when (zerop (nndiscourse-hash-count (nndiscourse-by-server server :categories-hashtb)))
|
|
(nndiscourse-request-list server))
|
|
(cl-loop
|
|
with new-posts
|
|
for page-bottom = 1 then (plist-get (elt posts (1- (length posts))) :id)
|
|
for posts = (nndiscourse-get-posts server :before (1- page-bottom))
|
|
until (null posts)
|
|
do (unless (nndiscourse-by-server server :last-id)
|
|
(setf (nndiscourse-by-server server :last-id)
|
|
(1- (plist-get (elt posts (1- (length posts))) :id))))
|
|
do (cl-do* ((k 0 (1+ k))
|
|
(plst (and (< k (length posts)) (elt posts k))
|
|
(and (< k (length posts)) (elt posts k))))
|
|
((or (null plst)
|
|
(<= (plist-get plst :id) (nndiscourse-by-server server :last-id))))
|
|
(push plst new-posts))
|
|
until (<= (1- (plist-get (elt posts (1- (length posts))) :id))
|
|
(nndiscourse-by-server server :last-id))
|
|
finally
|
|
(let ((counts (gnus-make-hashtable)))
|
|
(dolist (plst new-posts)
|
|
(setf (nndiscourse-by-server server :last-id) (plist-get plst :id))
|
|
(-when-let* ((not-deleted (not (plist-get plst :deleted_at)))
|
|
(type (plist-get plst :post_type))
|
|
(category-id (plist-get plst :category_id))
|
|
(group (nndiscourse-get-category server category-id))
|
|
(full-group (gnus-group-full-name
|
|
group
|
|
(cons 'nndiscourse (list server)))))
|
|
(aif (plist-get plst :reply_to_post_number)
|
|
(nndiscourse-set-ref server
|
|
(plist-get plst :id)
|
|
(plist-get (nndiscourse--number-to-header
|
|
server group
|
|
(plist-get plst :topic_id) it)
|
|
:id))
|
|
(awhen (plist-get (nndiscourse--earliest-header
|
|
server group
|
|
(plist-get plst :topic_id))
|
|
:id)
|
|
(nndiscourse-set-ref server (plist-get plst :id) it)))
|
|
(nndiscourse--replace-hash type (lambda (x) (1+ (or x 0))) counts)
|
|
(if-let ((info (gnus-get-info full-group)))
|
|
(progn
|
|
(unless (gnus-info-read info)
|
|
(setf (gnus-info-read info)
|
|
(gnus-range-normalize `(1 . ,(1- (plist-get plst :id))))))
|
|
(-when-let* ((last-number (nndiscourse--last-article-number server group))
|
|
(next-number (plist-get plst :id))
|
|
(gap `(,(1+ last-number) . ,(1- next-number))))
|
|
(when (<= (car gap) (cdr gap))
|
|
(setf (gnus-info-read info)
|
|
(gnus-range-add (gnus-info-read info) (gnus-range-normalize gap)))
|
|
(when (gnus-info-marks info)
|
|
(setf (alist-get 'unexist (gnus-info-marks info)) nil)))))
|
|
(gnus-message 3 "nndiscourse--incoming: cannot update read for %s" group))
|
|
(nndiscourse-set-headers server group
|
|
(nconc (nndiscourse-get-headers server group) (list plst)))))
|
|
(gnus-message
|
|
5 (concat "nndiscourse--incoming: "
|
|
(format "last-id: %s, " (nndiscourse-by-server server :last-id))
|
|
(let ((result ""))
|
|
(nndiscourse--maphash
|
|
(lambda (key value)
|
|
(setq result (concat result (format "type=%s +%s " key value))))
|
|
counts)
|
|
result))))))
|
|
|
|
(deffoo nndiscourse-request-scan (&optional _group server)
|
|
(when (nndiscourse-good-server server)
|
|
(if (> 2 (- (truncate (float-time)) (nndiscourse-by-server server :last-scan-time)))
|
|
(gnus-message 7 "nndiscourse-request-scan: last scanned at %s"
|
|
(current-time-string (nndiscourse-by-server server :last-scan-time)))
|
|
(cl-destructuring-bind (seconds num-gc seconds-gc)
|
|
(benchmark-run (nndiscourse--incoming server))
|
|
(setf (nndiscourse-by-server server :last-scan-time) (truncate (float-time)))
|
|
(gnus-message 5 (concat "nndiscourse-request-scan: Took %s seconds,"
|
|
" with %s gc runs taking %s seconds")
|
|
seconds num-gc seconds-gc)))))
|
|
|
|
(defsubst nndiscourse--make-message-id (id)
|
|
"Construct a valid Gnus message id from ID."
|
|
(format "<%s@discourse.org>" id))
|
|
|
|
(defsubst nndiscourse--make-references (server id)
|
|
"For SERVER, construct a space delimited string of message ancestors of ID."
|
|
(mapconcat (lambda (ref) (nndiscourse--make-message-id ref))
|
|
(nndiscourse-get-refs server id) " "))
|
|
|
|
(defsubst nndiscourse--make-header (server group article-number)
|
|
"Construct mail headers from article header.
|
|
For SERVER GROUP article headers, construct mail headers from ARTICLE-NUMBER'th
|
|
article header. Gnus manual does say the term `header` is oft conflated."
|
|
(when-let ((header (nndiscourse--get-header server group article-number)))
|
|
(let ((score (plist-get header :score))
|
|
(reads (plist-get header :reads)))
|
|
(make-full-mail-header
|
|
article-number
|
|
(plist-get header :topic_title)
|
|
(plist-get header :username)
|
|
(format-time-string "%a, %d %h %Y %T %z (%Z)" (date-to-time (plist-get header :created_at)))
|
|
(nndiscourse--make-message-id (plist-get header :id))
|
|
(nndiscourse--make-references server (plist-get header :id))
|
|
0 0 nil
|
|
(append `((X-Discourse-Name . ,(plist-get header :name)))
|
|
`((X-Discourse-ID . ,(plist-get header :id)))
|
|
`((X-Discourse-Permalink . ,(format "%s/t/%s/%s/%s"
|
|
server
|
|
(plist-get header :topic_slug)
|
|
(plist-get header :topic_id)
|
|
(plist-get header :id))))
|
|
(and (numberp score)
|
|
`((X-Discourse-Score . ,(number-to-string (truncate score)))))
|
|
(and (numberp reads)
|
|
`((X-Discourse-Reads . ,(number-to-string (truncate reads))))))))))
|
|
|
|
;; CORS denial
|
|
(defalias 'nndiscourse--request #'ignore)
|
|
|
|
(deffoo nndiscourse-request-article (article-number &optional group server buffer)
|
|
(unless buffer (setq buffer nntp-server-buffer))
|
|
(nndiscourse--with-group server group
|
|
(with-current-buffer buffer
|
|
(erase-buffer)
|
|
(let* ((header (nndiscourse--get-header server group article-number))
|
|
(mail-header (nndiscourse--make-header server group article-number))
|
|
(score (cdr (assq 'X-Discourse-Score (mail-header-extra mail-header))))
|
|
(permalink (cdr (assq 'X-Discourse-Permalink (mail-header-extra mail-header))))
|
|
(body (nndiscourse--massage (plist-get header :cooked))))
|
|
(when body
|
|
(insert
|
|
"Newsgroups: " group "\n"
|
|
"Subject: " (mail-header-subject mail-header) "\n"
|
|
"From: " (or (mail-header-from mail-header) "nobody") "\n"
|
|
"Date: " (mail-header-date mail-header) "\n"
|
|
"Message-ID: " (mail-header-id mail-header) "\n"
|
|
"References: " (mail-header-references mail-header) "\n"
|
|
"Archived-at: " permalink "\n"
|
|
"Score: " score "\n"
|
|
"\n")
|
|
(mml-insert-multipart "alternative")
|
|
(mml-insert-tag 'part 'type "text/html"
|
|
'disposition "inline"
|
|
'charset "utf-8")
|
|
(save-excursion (mml-insert-tag '/part))
|
|
(-when-let*
|
|
((parent (car (last (nndiscourse-get-refs server (plist-get header :id)))))
|
|
(parent-author
|
|
(or (plist-get (nndiscourse--get-header server group parent)
|
|
:username)
|
|
"Someone"))
|
|
(parent-body (nndiscourse--massage
|
|
(plist-get
|
|
(nndiscourse--get-header server group parent)
|
|
:cooked))))
|
|
(insert (nndiscourse--citation-wrap parent-author parent-body)))
|
|
(insert body)
|
|
(insert "\n")
|
|
(if (mml-validate)
|
|
(message-encode-message-body)
|
|
(gnus-message 2 "nndiscourse-request-article: Invalid mml:\n%s"
|
|
(buffer-string)))
|
|
(cons group article-number))))))
|
|
|
|
(deffoo nndiscourse-retrieve-headers (article-numbers &optional group server _fetch-old)
|
|
(with-current-buffer nntp-server-buffer
|
|
(erase-buffer)
|
|
(nndiscourse--with-group server group
|
|
(dolist (i article-numbers)
|
|
(when-let ((header (nndiscourse--make-header server group i)))
|
|
(nnheader-insert-nov header)))
|
|
'nov)))
|
|
|
|
;; Primarily because `gnus-get-unread-articles' won't update unreads
|
|
;; upon install (nndiscourse won't yet be in type-cache),
|
|
;; I am counting on logic in `gnus-read-active-file-1' in `gnus-get-unread-articles'
|
|
;; to get here upon install.
|
|
(deffoo nndiscourse-retrieve-groups (_groups &optional server)
|
|
(when (nndiscourse-good-server server)
|
|
;; Utterly insane thing where `gnus-active-to-gnus-format' expects
|
|
;; `gnus-request-list' output to be in `nntp-server-buffer'
|
|
;; and populates `gnus-active-hashtb'
|
|
(nndiscourse-request-list server)
|
|
(with-current-buffer nntp-server-buffer
|
|
(let (gnus-server-method-cache
|
|
(gnus-select-method '(nnnil)))
|
|
(gnus-active-to-gnus-format
|
|
(gnus-server-to-method (format "nndiscourse:%s" server))
|
|
gnus-active-hashtb nil t)))
|
|
(mapc (lambda (group)
|
|
(let ((full-name (gnus-group-full-name group `(nndiscourse ,server))))
|
|
(gnus-get-unread-articles-in-group (gnus-get-info full-name)
|
|
(gnus-active full-name))))
|
|
(nndiscourse-hash-values (nndiscourse-by-server server :categories-hashtb)))
|
|
;; `gnus-read-active-file-2' will now repeat what I just did. Brutal.
|
|
'active))
|
|
|
|
(deffoo nndiscourse-request-list (&optional server)
|
|
(let ((groups (nndiscourse-hash-values (nndiscourse-by-server server :categories-hashtb))))
|
|
(when (and (nndiscourse-good-server server) (nndiscourse-server-opened server))
|
|
(with-current-buffer nntp-server-buffer
|
|
(unless groups
|
|
(mapc
|
|
(lambda (plst)
|
|
(let ((group (plist-get plst :slug)))
|
|
(when (and group (not (zerop (length group))))
|
|
(let* ((category-id (plist-get plst :id))
|
|
(full-name (gnus-group-full-name group `(nndiscourse ,server)))
|
|
(subcategory-ids (append (plist-get plst :subcategory_ids) nil))
|
|
(must-subscribe (not (gnus-get-info full-name))))
|
|
(erase-buffer)
|
|
;; only `gnus-activate-group' seems to call `gnus-parse-active'
|
|
(gnus-activate-group full-name nil nil `(nndiscourse ,server))
|
|
(when must-subscribe
|
|
(funcall (if (fboundp 'gnus-group-set-subscription)
|
|
#'gnus-group-set-subscription
|
|
(with-no-warnings
|
|
#'gnus-group-unsubscribe-group))
|
|
full-name gnus-level-default-subscribed t))
|
|
(nndiscourse-set-category server category-id group)
|
|
(dolist (sub-id subcategory-ids)
|
|
(nndiscourse-set-category server sub-id group))
|
|
(push group groups)))))
|
|
(nndiscourse-get-categories server)))
|
|
(erase-buffer)
|
|
(mapc (lambda (group)
|
|
(insert
|
|
(format "%s %d %d y\n" group
|
|
(aif (nndiscourse--last-article-number server group)
|
|
it 0)
|
|
(aif (nndiscourse--first-article-number server group)
|
|
it 1))))
|
|
groups)))
|
|
t))
|
|
|
|
(defun nndiscourse-sentinel (process event)
|
|
"Wipe headers state when PROCESS dies from EVENT."
|
|
(unless (string= "open" (substring event 0 4))
|
|
(gnus-message 2 "nndiscourse-sentinel: process %s %s"
|
|
(car (process-command process))
|
|
(replace-regexp-in-string "\n$" "" event))
|
|
(nndiscourse-close-server (process-name process))
|
|
(gnus-backlog-shutdown)))
|
|
|
|
(defun nndiscourse--message-user (server beg end _prev-len)
|
|
"Message SERVER related alert with `buffer-substring' from BEG to END."
|
|
(let ((string (buffer-substring beg end))
|
|
(magic "::user::"))
|
|
(when (string-prefix-p magic string)
|
|
(message "%s: %s" server (substring string (length magic))))))
|
|
|
|
;; C-c C-c from followup buffer
|
|
;; message-send-and-exit
|
|
;; message-send
|
|
;; message-send-method-alist=message-send-news-function=message-send-news
|
|
;; gnus-request-post
|
|
;; nndiscourse-request-post
|
|
(deffoo nndiscourse-request-post (&optional _server)
|
|
nil)
|
|
|
|
(defun nndiscourse--browse-post (&rest _args)
|
|
"What happens when I click on discourse Subject."
|
|
(-when-let* ((group-article gnus-article-current)
|
|
(server (nth 1 (gnus-find-method-for-group (car group-article))))
|
|
(header (nndiscourse--get-header
|
|
server
|
|
(gnus-group-real-name (car group-article))
|
|
(cdr group-article)))
|
|
(url (format "%s://%s/t/%s/%s/%s"
|
|
nndiscourse-scheme
|
|
server
|
|
(plist-get header :topic_slug)
|
|
(plist-get header :topic_id)
|
|
(plist-get header :post_number))))
|
|
(browse-url url)))
|
|
|
|
(defun nndiscourse--header-button-alist ()
|
|
"Construct a buffer-local `gnus-header-button-alist' for nndiscourse."
|
|
(let* ((result (copy-alist gnus-header-button-alist))
|
|
(references-value (assoc-default "References" result
|
|
(lambda (x y) (string-match-p y x))))
|
|
(references-key (car (rassq references-value result))))
|
|
(setq result (cl-delete "^Subject:" result :test (lambda (x y) (cl-search x (car y)))))
|
|
(setq result (cl-delete references-key result :test (lambda (x y) (cl-search x (car y)))))
|
|
(push (append '("^\\(Message-I[Dd]\\|^In-Reply-To\\):") references-value) result)
|
|
(push '("^Subject:" ": *\\(.+\\)$" 1 (>= gnus-button-browse-level 0)
|
|
nndiscourse--browse-post 1)
|
|
result)
|
|
result))
|
|
|
|
(defsubst nndiscourse--fallback-link ()
|
|
"Cannot render post."
|
|
(let* ((header (nndiscourse--get-header
|
|
(nth 1 (gnus-find-method-for-group (car gnus-article-current)))
|
|
(gnus-group-real-name (car gnus-article-current))
|
|
(cdr gnus-article-current)))
|
|
(body (nndiscourse--massage (plist-get header :cooked))))
|
|
(with-current-buffer gnus-original-article-buffer
|
|
(article-goto-body)
|
|
(delete-region (point) (point-max))
|
|
(insert body))))
|
|
|
|
(defalias 'nndiscourse--display-article
|
|
(lambda (article &optional all-headers header)
|
|
(condition-case-unless-debug err
|
|
(gnus-article-prepare article all-headers header)
|
|
(error
|
|
(if nndiscourse-render-post
|
|
(progn
|
|
(gnus-message 7 "nndiscourse--display-article: '%s' (falling back...)"
|
|
(error-message-string err))
|
|
(nndiscourse--fallback-link)
|
|
(gnus-article-prepare article all-headers))
|
|
(error (error-message-string err))))))
|
|
"In case of shr failures, dump original link.")
|
|
|
|
(defun nndiscourse-dump-diagnostics (server)
|
|
"Makefile recipe test-run. SERVER second element of `gnus-select-method'."
|
|
(aif (nndiscourse-alist-get server nndiscourse-processes nil nil #'equal)
|
|
(dolist (b `(,byte-compile-log-buffer
|
|
,gnus-group-buffer
|
|
"*Messages*"
|
|
,(buffer-name (process-buffer (nndiscourse-proc-info-process it)))
|
|
,(format " *%s-stderr*" server)))
|
|
(when (buffer-live-p (get-buffer b))
|
|
(princ (format "\nBuffer: %s\n%s\n\n" b (with-current-buffer b (buffer-string)))
|
|
#'external-debugging-output)))
|
|
(error "Server %s not found among %s" server (mapcar #'car nndiscourse-processes))))
|
|
|
|
(defsubst nndiscourse--dense-time (time)
|
|
"Convert TIME to a floating point number.
|
|
|
|
Written by John Wiegley (https://github.com/jwiegley/dot-emacs)."
|
|
(+ (* (car time) 65536.0)
|
|
(cadr time)
|
|
(/ (or (car (cdr (cdr time))) 0) 1000000.0)))
|
|
|
|
(defalias 'nndiscourse--format-time-elapsed
|
|
(lambda (header)
|
|
(condition-case nil
|
|
(let ((date (mail-header-date header)))
|
|
(if (> (length date) 0)
|
|
(let*
|
|
((then (nndiscourse--dense-time
|
|
(apply #'encode-time (parse-time-string date))))
|
|
(now (nndiscourse--dense-time (current-time)))
|
|
(diff (- now then))
|
|
(str
|
|
(cond
|
|
((>= 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))))
|
|
(t
|
|
(format "%3ds" (floor diff)))))
|
|
(stripped
|
|
(replace-regexp-in-string "\\.0" "" str)))
|
|
(concat (cond
|
|
((= 2 (length stripped)) " ")
|
|
((= 3 (length stripped)) " ")
|
|
(t ""))
|
|
stripped))))
|
|
;; print some spaces and pretend nothing happened.
|
|
(error " ")))
|
|
"Return time elapsed since HEADER was sent.
|
|
|
|
Written by John Wiegley (https://github.com/jwiegley/dot-emacs).")
|
|
|
|
;; Evade melpazoid!
|
|
(funcall #'fset 'gnus-user-format-function-S
|
|
(symbol-function 'nndiscourse--format-time-elapsed))
|
|
|
|
(let ((custom-defaults
|
|
;; For now, revert any user overrides that I can't predict.
|
|
(mapcar (lambda (x)
|
|
(let* ((var (cl-first x))
|
|
(sv (get var 'standard-value)))
|
|
(when (eq var 'gnus-default-adaptive-score-alist)
|
|
(setq sv (list `(quote
|
|
,(mapcar (lambda (entry)
|
|
(cons (car entry)
|
|
(assq-delete-all 'from (cdr entry))))
|
|
(eval (car sv)))))))
|
|
(cons var sv)))
|
|
(seq-filter (lambda (x) (eq 'custom-variable (cl-second x)))
|
|
(append (get 'gnus-score-adapt 'custom-group)
|
|
(get 'gnus-score-default 'custom-group))))))
|
|
(add-to-list 'gnus-parameters `("^nndiscourse"
|
|
,@custom-defaults
|
|
(gnus-summary-make-false-root 'adopt)
|
|
(gnus-cite-hide-absolute 5)
|
|
(gnus-cite-hide-percentage 0)
|
|
(gnus-cited-lines-visible '(2 . 2))
|
|
(gnus-simplify-subject-functions (quote (gnus-simplify-subject-fuzzy)))
|
|
(gnus-summary-line-format "%3t%U%R%uS %I%(%*%-10,10f %s%)\n")
|
|
(gnus-auto-extend-newsgroup nil)
|
|
(gnus-add-timestamp-to-message t)
|
|
(gnus-summary-display-article-function
|
|
(quote ,(symbol-function 'nndiscourse--display-article)))
|
|
(gnus-header-button-alist
|
|
(quote ,(nndiscourse--header-button-alist)))
|
|
(gnus-visible-headers ,(concat gnus-visible-headers "\\|^Score:")))))
|
|
|
|
(defun nndiscourse-article-mode-activate ()
|
|
"Augment the `gnus-article-mode-map' conditionally."
|
|
(when (nndiscourse--gate)
|
|
(nndiscourse-article-mode)))
|
|
|
|
(defun nndiscourse-summary-mode-activate ()
|
|
"Shadow some bindings in `gnus-summary-mode-map' conditionally."
|
|
(when (nndiscourse--gate)
|
|
(nndiscourse-summary-mode)))
|
|
|
|
(nnoo-define-skeleton nndiscourse)
|
|
|
|
(defsubst nndiscourse--who-am-i ()
|
|
"Get my Discourse username."
|
|
"dickmao")
|
|
|
|
;; I believe I did try buffer-localizing hooks, and it wasn't sufficient
|
|
(add-hook 'gnus-article-mode-hook #'nndiscourse-article-mode-activate)
|
|
(add-hook 'gnus-summary-mode-hook #'nndiscourse-summary-mode-activate)
|
|
|
|
;; `gnus-newsgroup-p' requires valid method post-mail to return t
|
|
(add-to-list 'gnus-valid-select-methods '("nndiscourse" post-mail) t)
|
|
|
|
(add-function
|
|
:filter-return (symbol-function 'message-make-fqdn)
|
|
(lambda (val)
|
|
(if (and (nndiscourse--gate)
|
|
(cl-search "--so-tickle-me" val))
|
|
"discourse.org" val)))
|
|
|
|
(add-function
|
|
:before-until (symbol-function 'message-make-from)
|
|
(lambda (&rest _args)
|
|
(when (nndiscourse--gate)
|
|
(concat (nndiscourse--who-am-i) "@discourse.org"))))
|
|
|
|
;; the let'ing to nil of `gnus-summary-display-article-function'
|
|
;; in `gnus-summary-select-article' dates back to antiquity.
|
|
(add-function
|
|
:around (symbol-function 'gnus-summary-display-article)
|
|
(lambda (f &rest args)
|
|
(cond ((nndiscourse--gate)
|
|
(let ((gnus-summary-display-article-function
|
|
(symbol-function 'nndiscourse--display-article)))
|
|
(apply f args)))
|
|
(t (apply f args)))))
|
|
|
|
;; possible impostors
|
|
(setq gnus-valid-select-methods (cl-remove-if (lambda (method)
|
|
(equal (car method) "nndiscourse"))
|
|
gnus-valid-select-methods))
|
|
(gnus-declare-backend "nndiscourse" 'post-mail 'address)
|
|
|
|
(provide 'nndiscourse)
|
|
|
|
;;; nndiscourse.el ends here
|