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