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

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