cgit.sxemacs.org Git - gnus/blob - lisp/hashcash.el

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