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

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