lisp/mail/hashcash.el

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