Add hashcash.el

diff --git a/contrib/ChangeLog b/contrib/ChangeLog
index b31b39b..6ffbb0c 100644 (file)
--- a/contrib/ChangeLog
+++ b/contrib/ChangeLog
@@ -1,3 +1,7 @@
+2002-06-22  Simon Josefsson  <jas@extundo.com>
+
+       * hashcash.el: New file.
+
 2002-05-20  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
        * gnus-mdrtn.el (gnus-moderated-groups): Removed (require 'gnus-load).

diff --git a/contrib/hashcash.el b/contrib/hashcash.el
new file mode 100644 (file)
index 0000000..48ff0b6
--- /dev/null
+++ b/contrib/hashcash.el
@@ -0,0 +1,106 @@
+;;; hashcash.el --- Add hashcash payments to email
+
+;; $Revision: 2.6 $
+;; Copyright (C) 1997,2001 Paul E. Foley
+
+;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
+;; Keywords: mail, hashcash
+
+;; Released under the GNU General Public License
+
+;;; Commentary:
+
+;; The hashcash binary is at http://www.cypherspace.org/hashcash/
+;;
+;; Call mail-add-payment to add a hashcash payment to a mail message
+;; in the current buffer.
+;;
+;; To automatically add payments to all outgoing mail:
+;;    (add-hook 'message-send-hook 'mail-add-payment)
+
+;;; Code:
+
+(defvar hashcash-default-payment 0
+  "*The default number of bits to pay to unknown users.
+ If this is zero, no payment header will be generated.
+ See hashcash-payment-alist.")
+(defvar hashcash-payment-alist nil
+  "*An association list mapping email addresses to payment amounts.
+ Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where
+ ADDR is the email address of the intended recipient and AMOUNT is
+ the value of hashcash payment to be made to that user.  STRING, if
+ present, is the string to be hashed; if not present ADDR will be used.")
+(defvar hashcash "/usr/local/bin/hashcash"
+  "*The path to the hashcash binary.")
+
+(require 'mail-utils)
+
+(defun hashcash-strip-quoted-names (addr)
+  (setq addr (mail-strip-quoted-names addr))
+  (if (and addr (string-match "^[^+@]+\\(\\+[^@]*\\)@" addr))
+      (concat (subseq addr 0 (match-beginning 1)) (subseq addr (match-end 1)))
+    addr))
+
+(defun hashcash-payment-required (addr)
+  "Return the hashcash payment value required for the given address."
+  (let ((val (assoc addr hashcash-payment-alist)))
+    (if val
+       (if (cddr val)
+           (caddr val)
+         (cadr val))
+      hashcash-default-payment)))
+
+(defun hashcash-payment-to (addr)
+  "Return the string with which hashcash payments should collide."
+  (let ((val (assoc addr hashcash-payment-alist)))
+    (if val
+       (if (cddr val)
+           (cadr val)
+         (car val))
+      addr)))
+
+(defun hashcash-generate-payment (str val)
+  "Generate a hashcash payment by finding a VAL-bit collison on STR."
+  (if (> val 0)
+      (save-excursion
+       (set-buffer (get-buffer-create " *hashcash*"))
+       (erase-buffer)
+       (call-process hashcash nil t nil (concat "-" (number-to-string val))
+                     str)
+       (search-backward "collision: ")
+       (forward-char 11)
+       (let ((pos (point-marker)))
+         (end-of-line)
+         (buffer-substring pos (point))))
+    nil))
+
+(defun hashcash-insert-payment (arg)
+  "Insert an X-Payment header with a payment for ARG"
+  (interactive "sPay to: ")
+  (let ((pay (hashcash-generate-payment (hashcash-payment-to arg)
+                                       (hashcash-payment-required arg))))
+    (when pay
+      (insert-before-markers "X-Payment: " pay "\n"))))
+
+(defun mail-add-payment (&optional arg)
+  "Add an X-Payment: header with a hashcash payment for each recipient address
+Prefix arg sets default payment temporarily."
+  (interactive "P")
+  (let ((hashcash-default-payment (if arg (prefix-numeric-value arg)
+                                   hashcash-default-payment))
+       (addrlist nil))
+    (save-excursion
+      (save-restriction
+       (goto-char (point-min))
+       (search-forward mail-header-separator)
+       (beginning-of-line)
+       (narrow-to-region (point-min) (point))
+       (let ((to (hashcash-strip-quoted-names (mail-fetch-field "To" nil t)))
+             (cc (hashcash-strip-quoted-names (mail-fetch-field "Cc" nil t))))
+         (when to
+           (setq addrlist (split-string to ",[ \t\n]*")))
+         (when cc
+           (setq addrlist (nconc addrlist (split-string cc ",[ \t\n]*")))))
+       (when addrlist
+         (mapc #'hashcash-insert-payment addrlist)))))
+  t)