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

   1 ;;; hashcash.el --- Add hashcash payments to email
   2
   3 ;; Copyright (C) 2003-2005, 2007-2014 Free Software Foundation, Inc.
   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 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; The hashcash binary is at http://www.hashcash.org/.
  27 ;;
  28 ;; Call mail-add-payment to add a hashcash payment to a mail message
  29 ;; in the current buffer.
  30 ;;
  31 ;; Call mail-add-payment-async after writing the addresses but before
  32 ;; writing the mail to start calculating the hashcash payment
  33 ;; asynchronously.
  34 ;;
  35 ;; The easiest way to do this automatically for all outgoing mail
  36 ;; is to set `message-generate-hashcash' to t.  If you want more
  37 ;; control, try the following hooks.
  38 ;;
  39 ;; To automatically add payments to all outgoing mail when sending:
  40 ;;    (add-hook 'message-send-hook 'mail-add-payment)
  41 ;;
  42 ;; To start calculations automatically when addresses are prefilled:
  43 ;;    (add-hook 'message-setup-hook 'mail-add-payment-async)
  44 ;;
  45 ;; To check whether calculations are done before sending:
  46 ;;    (add-hook 'message-send-hook 'hashcash-wait-or-cancel)
  47
  48 ;;; Code:
  49
  50 ;; For Emacs <22.2 and XEmacs.
  51 (eval-and-compile
  52   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  53
  54 (eval-when-compile (require 'cl))       ; for case
  55
  56 (defgroup hashcash nil
  57   "Hashcash configuration."
  58   :group 'mail)
  59
  60 (defcustom hashcash-default-payment 20
  61   "The default number of bits to pay to unknown users.
  62 If this is zero, no payment header will be generated.
  63 See `hashcash-payment-alist'."
  64   :type 'integer
  65   :group 'hashcash)
  66
  67 (defcustom hashcash-payment-alist '()
  68   "An association list mapping email addresses to payment amounts.
  69 Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where
  70 ADDR is the email address of the intended recipient and AMOUNT is
  71 the value of hashcash payment to be made to that user.  STRING, if
  72 present, is the string to be hashed; if not present ADDR will be used."
  73   :type '(repeat (choice (list :tag "Normal"
  74                                (string :name "Address")
  75                                (integer :name "Amount"))
  76                          (list :tag "Replace hash input"
  77                                (string :name "Address")
  78                                (string :name "Hash input")
  79                                (integer :name "Amount"))))
  80   :group 'hashcash)
  81
  82 (defcustom hashcash-default-accept-payment 20
  83   "The default minimum number of bits to accept on incoming payments."
  84   :type 'integer
  85   :group 'hashcash)
  86
  87 (defcustom hashcash-accept-resources `((,user-mail-address nil))
  88   "An association list mapping hashcash resources to payment amounts.
  89 Resources named here are to be accepted in incoming payments.  If the
  90 corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment'
  91 is used instead."
  92   :type 'alist
  93   :group 'hashcash)
  94
  95 (define-obsolete-variable-alias 'hashcash-path 'hashcash-program "24.4")
  96 (defcustom hashcash-program "hashcash"
  97   "The name of the hashcash executable.
  98 If this is not in your PATH, specify an absolute file name."
  99   :type '(choice (const nil) file)
 100   :group 'hashcash)
 101
 102 (defcustom hashcash-extra-generate-parameters nil
 103   "A list of parameter strings passed to `hashcash-program' when minting.
 104 For example, you may want to set this to '(\"-Z2\") to reduce header length."
 105   :type '(repeat string)
 106   :group 'hashcash)
 107
 108 (defcustom hashcash-double-spend-database "hashcash.db"
 109   "The name of the double-spending database file."
 110   :type 'file
 111   :group 'hashcash)
 112
 113 (defcustom hashcash-in-news nil
 114   "Specifies whether or not hashcash payments should be made to newsgroups."
 115   :type 'boolean
 116   :group 'hashcash)
 117
 118 (defvar hashcash-process-alist nil
 119   "Alist of asynchronous hashcash processes and buffers.")
 120
 121 (require 'mail-utils)
 122
 123 (eval-and-compile
 124   (if (fboundp 'point-at-bol)
 125       (defalias 'hashcash-point-at-bol 'point-at-bol)
 126     (defalias 'hashcash-point-at-bol 'line-beginning-position))
 127
 128   (if (fboundp 'point-at-eol)
 129       (defalias 'hashcash-point-at-eol 'point-at-eol)
 130     (defalias 'hashcash-point-at-eol 'line-end-position)))
 131
 132 (defun hashcash-strip-quoted-names (addr)
 133   (setq addr (mail-strip-quoted-names addr))
 134   (if (and addr (string-match "\\`\\([^+@]+\\)\\+[^@]*\\(@.+\\)" addr))
 135       (concat (match-string 1 addr) (match-string 2 addr))
 136     addr))
 137
 138 (declare-function message-narrow-to-headers-or-head "message" ())
 139 (declare-function message-fetch-field "message" (header &optional not-all))
 140 (declare-function message-goto-eoh "message" ())
 141 (declare-function message-narrow-to-headers "message" ())
 142
 143 (defun hashcash-token-substring ()
 144   (save-excursion
 145     (let ((token ""))
 146       (loop
 147         (setq token
 148           (concat token (buffer-substring (point) (hashcash-point-at-eol))))
 149         (goto-char (hashcash-point-at-eol))
 150         (forward-char 1)
 151         (unless (looking-at "[ \t]") (return token))
 152         (while (looking-at "[ \t]") (forward-char 1))))))
 153
 154 (defun hashcash-payment-required (addr)
 155   "Return the hashcash payment value required for the given address."
 156   (let ((val (assoc addr hashcash-payment-alist)))
 157     (or (nth 2 val) (nth 1 val) hashcash-default-payment)))
 158
 159 (defun hashcash-payment-to (addr)
 160   "Return the string with which hashcash payments should collide."
 161   (let ((val (assoc addr hashcash-payment-alist)))
 162     (or (nth 1 val) (nth 0 val) addr)))
 163
 164 (defun hashcash-generate-payment (str val)
 165   "Generate a hashcash payment by finding a VAL-bit collison on STR."
 166   (if (and (> val 0)
 167            hashcash-program)
 168       (with-current-buffer (get-buffer-create " *hashcash*")
 169         (erase-buffer)
 170         (apply 'call-process hashcash-program nil t nil
 171                "-m" "-q" "-b" (number-to-string val) str
 172                hashcash-extra-generate-parameters)
 173         (goto-char (point-min))
 174         (hashcash-token-substring))
 175     (error "No `hashcash' binary found")))
 176
 177 (defun hashcash-generate-payment-async (str val callback)
 178   "Generate a hashcash payment by finding a VAL-bit collison on STR.
 179 Return immediately.  Call CALLBACK with process and result when ready."
 180   (if (and (> val 0)
 181            hashcash-program)
 182       (let ((process (apply 'start-process "hashcash" nil
 183                             hashcash-program "-m" "-q"
 184                             "-b" (number-to-string val) str
 185                             hashcash-extra-generate-parameters)))
 186         (setq hashcash-process-alist (cons
 187                                       (cons process (current-buffer))
 188                                       hashcash-process-alist))
 189         (set-process-filter process `(lambda (process output)
 190                                        (funcall ,callback process output))))
 191     (funcall callback nil nil)))
 192
 193 (defun hashcash-check-payment (token str val)
 194   "Check the validity of a hashcash payment."
 195   (if hashcash-program
 196       (zerop (call-process hashcash-program nil nil nil "-c"
 197                            "-d" "-f" hashcash-double-spend-database
 198                            "-b" (number-to-string val)
 199                            "-r" str
 200                            token))
 201     (progn
 202       (message "No hashcash binary found")
 203       (sleep-for 1)
 204       nil)))
 205