70170654f67b51fd1d724222c7d767e0745c6fc6
[gnus] / lisp / hashcash.el
1 ;;; hashcash.el --- Add hashcash payments to email
2
3 ;; Copyright (C) 2003-2005, 2007-2015 Free Software Foundation, Inc.
4
5 ;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002)
6 ;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
7 ;; Keywords: mail, hashcash
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;; The hashcash binary is at http://www.hashcash.org/.
27 ;;
28 ;; Call mail-add-payment to add a hashcash payment to a mail message
29 ;; in the current buffer.
30 ;;
31 ;; Call mail-add-payment-async after writing the addresses but before
32 ;; writing the mail to start calculating the hashcash payment
33 ;; asynchronously.
34 ;;
35 ;; The easiest way to do this automatically for all outgoing mail
36 ;; is to set `message-generate-hashcash' to t.  If you want more
37 ;; control, try the following hooks.
38 ;;
39 ;; To automatically add payments to all outgoing mail when sending:
40 ;;    (add-hook 'message-send-hook 'mail-add-payment)
41 ;;
42 ;; To start calculations automatically when addresses are prefilled:
43 ;;    (add-hook 'message-setup-hook 'mail-add-payment-async)
44 ;;
45 ;; To check whether calculations are done before sending:
46 ;;    (add-hook 'message-send-hook 'hashcash-wait-or-cancel)
47
48 ;;; Code:
49
50 (eval-when-compile (require 'cl))       ; for case
51
52 (defgroup hashcash nil
53   "Hashcash configuration."
54   :group 'mail)
55
56 (defcustom hashcash-default-payment 20
57   "The default number of bits to pay to unknown users.
58 If this is zero, no payment header will be generated.
59 See `hashcash-payment-alist'."
60   :type 'integer
61   :group 'hashcash)
62
63 (defcustom hashcash-payment-alist '()
64   "An association list mapping email addresses to payment amounts.
65 Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where
66 ADDR is the email address of the intended recipient and AMOUNT is
67 the value of hashcash payment to be made to that user.  STRING, if
68 present, is the string to be hashed; if not present ADDR will be used."
69   :type '(repeat (choice (list :tag "Normal"
70                                (string :name "Address")
71                                (integer :name "Amount"))
72                          (list :tag "Replace hash input"
73                                (string :name "Address")
74                                (string :name "Hash input")
75                                (integer :name "Amount"))))
76   :group 'hashcash)
77
78 (defcustom hashcash-default-accept-payment 20
79   "The default minimum number of bits to accept on incoming payments."
80   :type 'integer
81   :group 'hashcash)
82
83 (defcustom hashcash-accept-resources `((,user-mail-address nil))
84   "An association list mapping hashcash resources to payment amounts.
85 Resources named here are to be accepted in incoming payments.  If the
86 corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment'
87 is used instead."
88   :type 'alist
89   :group 'hashcash)
90
91 (define-obsolete-variable-alias 'hashcash-path 'hashcash-program "24.4")
92 (defcustom hashcash-program "hashcash"
93   "The name of the hashcash executable.
94 If this is not in your PATH, specify an absolute file name."
95   :type '(choice (const nil) file)
96   :group 'hashcash)
97
98 (defcustom hashcash-extra-generate-parameters nil
99   "A list of parameter strings passed to `hashcash-program' when minting.
100 For example, you may want to set this to '(\"-Z2\") to reduce header length."
101   :type '(repeat string)
102   :group 'hashcash)
103
104 (defcustom hashcash-double-spend-database "hashcash.db"
105   "The name of the double-spending database file."
106   :type 'file
107   :group 'hashcash)
108
109 (defcustom hashcash-in-news nil
110   "Specifies whether or not hashcash payments should be made to newsgroups."
111   :type 'boolean
112   :group 'hashcash)
113
114 (defvar hashcash-process-alist nil
115   "Alist of asynchronous hashcash processes and buffers.")
116
117 (require 'mail-utils)
118
119 (eval-and-compile
120   (if (fboundp 'point-at-bol)
121       (defalias 'hashcash-point-at-bol 'point-at-bol)
122     (defalias 'hashcash-point-at-bol 'line-beginning-position))
123
124   (if (fboundp 'point-at-eol)
125       (defalias 'hashcash-point-at-eol 'point-at-eol)
126     (defalias 'hashcash-point-at-eol 'line-end-position)))
127
128 (defun hashcash-strip-quoted-names (addr)
129   (setq addr (mail-strip-quoted-names addr))
130   (if (and addr (string-match "\\`\\([^+@]+\\)\\+[^@]*\\(@.+\\)" addr))
131       (concat (match-string 1 addr) (match-string 2 addr))
132     addr))
133
134 (declare-function message-narrow-to-headers-or-head "message" ())
135 (declare-function message-fetch-field "message" (header &optional not-all))
136 (declare-function message-goto-eoh "message" ())
137 (declare-function message-narrow-to-headers "message" ())
138
139 (defun hashcash-token-substring ()
140   (save-excursion
141     (let ((token ""))
142       (loop
143         (setq token
144           (concat token (buffer-substring (point) (hashcash-point-at-eol))))
145         (goto-char (hashcash-point-at-eol))
146         (forward-char 1)
147         (unless (looking-at "[ \t]") (return token))
148         (while (looking-at "[ \t]") (forward-char 1))))))
149
150 (defun hashcash-payment-required (addr)
151   "Return the hashcash payment value required for the given address."
152   (let ((val (assoc addr hashcash-payment-alist)))
153     (or (nth 2 val) (nth 1 val) hashcash-default-payment)))
154
155 (defun hashcash-payment-to (addr)
156   "Return the string with which hashcash payments should collide."
157   (let ((val (assoc addr hashcash-payment-alist)))
158     (or (nth 1 val) (nth 0 val) addr)))
159
160 (defun hashcash-generate-payment (str val)
161   "Generate a hashcash payment by finding a VAL-bit collison on STR."
162   (if (and (> val 0)
163            hashcash-program)
164       (with-current-buffer (get-buffer-create " *hashcash*")
165         (erase-buffer)
166         (apply 'call-process hashcash-program nil t nil
167                "-m" "-q" "-b" (number-to-string val) str
168                hashcash-extra-generate-parameters)
169         (goto-char (point-min))
170         (hashcash-token-substring))
171     (error "No `hashcash' binary found")))
172
173 (defun hashcash-generate-payment-async (str val callback)
174   "Generate a hashcash payment by finding a VAL-bit collison on STR.
175 Return immediately.  Call CALLBACK with process and result when ready."
176   (if (and (> val 0)
177            hashcash-program)
178       (let ((process (apply 'start-process "hashcash" nil
179                             hashcash-program "-m" "-q"
180                             "-b" (number-to-string val) str
181                             hashcash-extra-generate-parameters)))
182         (setq hashcash-process-alist (cons
183                                       (cons process (current-buffer))
184                                       hashcash-process-alist))
185         (set-process-filter process `(lambda (process output)
186                                        (funcall ,callback process output))))
187     (funcall callback nil nil)))
188
189 (defun hashcash-check-payment (token str val)
190   "Check the validity of a hashcash payment."
191   (if hashcash-program
192       (zerop (call-process hashcash-program nil nil nil "-c"
193                            "-d" "-f" hashcash-double-spend-database
194                            "-b" (number-to-string val)
195                            "-r" str
196                            token))
197     (progn
198       (message "No hashcash binary found")
199       (sleep-for 1)
200       nil)))
201
202 (defun hashcash-version (token)
203   "Find the format version of a hashcash token."
204   ;; Version 1.2 looks like n:yymmdd:rrrrr:xxxxxxxxxxxxxxxx
205   ;;   This carries its own version number embedded in the token,
206   ;;   so no further format number changes should be necessary
207   ;;   in the X-Payment header.
208   ;;
209   ;; Version 1.1 looks like yymmdd:rrrrr:xxxxxxxxxxxxxxxx
210   ;;   You need to upgrade your hashcash binary.
211   ;;
212   ;; Version 1.0 looked like nnnnnrrrrrxxxxxxxxxxxxxxxx
213   ;;   This is no longer supported.
214   (cond ((equal (aref token 1) ?:) 1.2)
215         ((equal (aref token 6) ?:) 1.1)
216         (t (error "Unknown hashcash format version"))))
217
218 (defun hashcash-already-paid-p (recipient)
219   "Check for hashcash token to RECIPIENT in current buffer."
220   (save-excursion
221     (save-restriction
222       (message-narrow-to-headers-or-head)
223       (let ((token (message-fetch-field "x-hashcash"))
224             (case-fold-search t))
225         (and (stringp token)
226              (string-match (regexp-quote recipient) token))))))
227
228 ;;;###autoload
229 (defun hashcash-insert-payment (arg)
230   "Insert X-Payment and X-Hashcash headers with a payment for ARG"
231   (interactive "sPay to: ")
232   (unless (hashcash-already-paid-p arg)
233     (let ((pay (hashcash-generate-payment (hashcash-payment-to arg)
234                                           (hashcash-payment-required arg))))
235       (when pay
236         (insert-before-markers "X-Hashcash: " pay "\n")))))
237
238 ;;;###autoload
239 (defun hashcash-insert-payment-async (arg)
240   "Insert X-Payment and X-Hashcash headers with a payment for ARG
241 Only start calculation.  Results are inserted when ready."
242   (interactive "sPay to: ")
243   (unless (hashcash-already-paid-p arg)
244     (hashcash-generate-payment-async
245      (hashcash-payment-to arg)
246      (hashcash-payment-required arg)
247      `(lambda (process payment)
248         (hashcash-insert-payment-async-2 ,(current-buffer) process payment)))))
249
250 (defun hashcash-insert-payment-async-2 (buffer process pay)
251   (when (buffer-live-p buffer)
252     (with-current-buffer buffer
253       (save-excursion
254         (save-restriction
255           (setq hashcash-process-alist (delq
256                                         (assq process hashcash-process-alist)
257                                         hashcash-process-alist))
258           (message-goto-eoh)
259           (when pay
260             (insert-before-markers "X-Hashcash: " pay)))))))
261
262 (defun hashcash-cancel-async (&optional buffer)
263   "Delete any hashcash processes associated with BUFFER.
264 BUFFER defaults to the current buffer."
265   (interactive)
266   (unless buffer (setq buffer (current-buffer)))
267   (let (entry)
268     (while (setq entry (rassq buffer hashcash-process-alist))
269       (delete-process (car entry))
270       (setq hashcash-process-alist
271             (delq entry hashcash-process-alist)))))
272
273 (defun hashcash-wait-async (&optional buffer)
274   "Wait for asynchronous hashcash processes in BUFFER to finish.
275 BUFFER defaults to the current buffer."
276   (interactive)
277   (unless buffer (setq buffer (current-buffer)))
278   (let (entry)
279     (while (setq entry (rassq buffer hashcash-process-alist))
280       (accept-process-output (car entry) 1))))
281
282 (defun hashcash-processes-running-p (buffer)
283   "Return non-nil if hashcash processes in BUFFER are still running."
284   (rassq buffer hashcash-process-alist))
285
286 (defun hashcash-wait-or-cancel ()
287   "Ask user whether to wait for hashcash processes to finish."
288   (interactive)
289   (when (hashcash-processes-running-p (current-buffer))
290     (if (y-or-n-p
291           "Hashcash process(es) still running; wait for them to finish? ")
292         (hashcash-wait-async)
293       (hashcash-cancel-async))))
294
295 ;;;###autoload
296 (defun hashcash-verify-payment (token &optional resource amount)
297   "Verify a hashcash payment"
298   (let* ((split (split-string token ":"))
299          (key (if (< (hashcash-version token) 1.2)
300                   (nth 1 split)
301                   (case (string-to-number (nth 0 split))
302                     (0 (nth 2 split))
303                     (1 (nth 3 split))))))
304     (cond ((null resource)
305            (let ((elt (assoc key hashcash-accept-resources)))
306              (and elt (hashcash-check-payment token (car elt)
307                         (or (cadr elt) hashcash-default-accept-payment)))))
308           ((equal token key)
309            (hashcash-check-payment token resource
310                                 (or amount hashcash-default-accept-payment)))
311           (t nil))))
312
313 ;;;###autoload
314 (defun mail-add-payment (&optional arg async)
315   "Add X-Payment: and X-Hashcash: headers with a hashcash payment
316 for each recipient address.  Prefix arg sets default payment temporarily.
317 Set ASYNC to t to start asynchronous calculation.  (See
318 `mail-add-payment-async')."
319   (interactive "P")
320   (let ((hashcash-default-payment (if arg (prefix-numeric-value arg)
321                                     hashcash-default-payment))
322         (addrlist nil))
323     (save-excursion
324       (save-restriction
325         (message-narrow-to-headers)
326         (let ((to (hashcash-strip-quoted-names (mail-fetch-field "To" nil t)))
327               (cc (hashcash-strip-quoted-names (mail-fetch-field "Cc" nil t)))
328               (ng (hashcash-strip-quoted-names (mail-fetch-field "Newsgroups"
329                                                                  nil t))))
330           (when to
331             (setq addrlist (split-string to ",[ \t\n]*")))
332           (when cc
333             (setq addrlist (nconc addrlist (split-string cc ",[ \t\n]*"))))
334           (when (and hashcash-in-news ng)
335             (setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*")))))
336         (when addrlist
337           (mapc (if async
338                     #'hashcash-insert-payment-async
339                   #'hashcash-insert-payment)
340                 addrlist)))))
341   t)
342
343 ;;;###autoload
344 (defun mail-add-payment-async (&optional arg)
345   "Add X-Payment: and X-Hashcash: headers with a hashcash payment
346 for each recipient address.  Prefix arg sets default payment temporarily.
347 Calculation is asynchronous."
348   (interactive "P")
349   (mail-add-payment arg t))
350
351 ;;;###autoload
352 (defun mail-check-payment (&optional arg)
353   "Look for a valid X-Payment: or X-Hashcash: header.
354 Prefix arg sets default accept amount temporarily."
355   (interactive "P")
356   (let ((hashcash-default-accept-payment (if arg (prefix-numeric-value arg)
357                                            hashcash-default-accept-payment))
358         (version (hashcash-version (hashcash-generate-payment "x" 1))))
359     (save-excursion
360       (goto-char (point-min))
361       (search-forward "\n\n")
362       (beginning-of-line)
363       (let ((end (point))
364             (ok nil))
365         (goto-char (point-min))
366         (while (and (not ok) (search-forward "X-Payment: hashcash " end t))
367           (let ((value (split-string (hashcash-token-substring) " ")))
368             (when (equal (car value) (number-to-string version))
369               (setq ok (hashcash-verify-payment (cadr value))))))
370         (goto-char (point-min))
371         (while (and (not ok) (search-forward "X-Hashcash: " end t))
372           (setq ok (hashcash-verify-payment (hashcash-token-substring))))
373         (when ok
374           (message "Payment valid"))
375         ok))))
376
377 (provide 'hashcash)
378
379 ;;; hashcash.el ends here