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

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