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

   1 ;;; hashcash.el --- Add hashcash payments to email
   2
   3 ;; Copyright (C) 2003-2005, 2007-2011
   4 ;;   Free Software Foundation
   5
   6 ;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002)
   7 ;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
   8 ;; Keywords: mail, hashcash
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; The hashcash binary is at http://www.hashcash.org/.
  28 ;;
  29 ;; Call mail-add-payment to add a hashcash payment to a mail message
  30 ;; in the current buffer.
  31 ;;
  32 ;; Call mail-add-payment-async after writing the addresses but before
  33 ;; writing the mail to start calculating the hashcash payment
  34 ;; asynchronously.
  35 ;;
  36 ;; The easiest way to do this automatically for all outgoing mail
  37 ;; is to set `message-generate-hashcash' to t.  If you want more
  38 ;; control, try the following hooks.
  39 ;;
  40 ;; To automatically add payments to all outgoing mail when sending:
  41 ;;    (add-hook 'message-send-hook 'mail-add-payment)
  42 ;;
  43 ;; To start calculations automatically when addresses are prefilled:
  44 ;;    (add-hook 'message-setup-hook 'mail-add-payment-async)
  45 ;;
  46 ;; To check whether calculations are done before sending:
  47 ;;    (add-hook 'message-send-hook 'hashcash-wait-or-cancel)
  48
  49 ;;; Code:
  50
  51 ;; For Emacs <22.2 and XEmacs.
  52 (eval-and-compile
  53   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  54
  55 (eval-when-compile (require 'cl))       ; for case
  56
  57 (defgroup hashcash nil
  58   "Hashcash configuration."
  59   :group 'mail)
  60
  61 (defcustom hashcash-default-payment 20
  62   "*The default number of bits to pay to unknown users.
  63 If this is zero, no payment header will be generated.
  64 See `hashcash-payment-alist'."
  65   :type 'integer
  66   :group 'hashcash)
  67
  68 (defcustom hashcash-payment-alist '()
  69   "*An association list mapping email addresses to payment amounts.
  70 Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where
  71 ADDR is the email address of the intended recipient and AMOUNT is
  72 the value of hashcash payment to be made to that user.  STRING, if
  73 present, is the string to be hashed; if not present ADDR will be used."
  74   :type '(repeat (choice (list :tag "Normal"
  75                                (string :name "Address")
  76                                (integer :name "Amount"))
  77                          (list :tag "Replace hash input"
  78                                (string :name "Address")
  79                                (string :name "Hash input")
  80                                (integer :name "Amount"))))
  81   :group 'hashcash)
  82
  83 (defcustom hashcash-default-accept-payment 20
  84   "*The default minimum number of bits to accept on incoming payments."
  85   :type 'integer
  86   :group 'hashcash)
  87
  88 (defcustom hashcash-accept-resources `((,user-mail-address nil))
  89   "*An association list mapping hashcash resources to payment amounts.
  90 Resources named here are to be accepted in incoming payments.  If the
  91 corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment'
  92 is used instead."
  93   :group 'hashcash)
  94
  95 (defcustom hashcash-path (executable-find "hashcash")
  96   "*The path to the hashcash binary."
  97   :group 'hashcash)
  98
  99 (defcustom hashcash-extra-generate-parameters nil
 100   "*A list of parameter strings passed to `hashcash-path' when minting.
 101 For example, you may want to set this to '(\"-Z2\") to reduce header length."
 102   :type '(repeat string)
 103   :group 'hashcash)
 104
 105 (defcustom hashcash-double-spend-database "hashcash.db"
 106   "*The path to the double-spending database."
 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-path)
 164       (with-current-buffer (get-buffer-create " *hashcash*")
 165         (erase-buffer)
 166         (apply 'call-process hashcash-path 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-path)
 178       (let ((process (apply 'start-process "hashcash" nil
 179                             hashcash-path "-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-path
 192       (zerop (call-process hashcash-path 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