;;; hashcash.el --- Add hashcash payments to email
-;; $Revision: 1.6 $
-;; Copyright (C) 1997,2001 Paul E. Foley
+;; $Revision: 1.12 $
+;; Copyright (C) 2003 Free Software Foundation
+;; Copyright (C) 1997--2002 Paul E. Foley
;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
;; Keywords: mail, hashcash
;; Released under the GNU General Public License
+;; (http://www.gnu.org/licenses/gpl.html)
;;; Commentary:
;;; Code:
+(eval-and-compile
+ (autoload 'executable-find "executable"))
+
(defcustom hashcash-default-payment 0
"*The default number of bits to pay to unknown users.
If this is zero, no payment header will be generated.
"*The default minimum number of bits to accept on incoming payments."
:type 'integer)
-(defcustom hashcash-accept-resources `((,(user-mail-address) nil))
+(defcustom hashcash-accept-resources `((,user-mail-address nil))
"*An association list mapping hashcash resources to payment amounts.
Resources named here are to be accepted in incoming payments. If the
corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment'
is used instead.")
-(defcustom hashcash "/usr/local/bin/hashcash"
+(defcustom hashcash-path (executable-find "hashcash")
"*The path to the hashcash binary.")
(defcustom hashcash-double-spend-database "hashcash.db"
(require 'mail-utils)
-(defalias 'hashcash-point-at-bol
- (if (fboundp 'point-at-bol)
- 'point-at-bol
- 'line-beginning-position))
+(eval-and-compile
+ (if (fboundp 'point-at-bol)
+ (defalias 'hashcash-point-at-bol 'point-at-bol)
+ (defalias 'hashcash-point-at-bol 'line-beginning-position))
-(defalias 'hashcash-point-at-eol
- (if (fboundp 'point-at-eol)
- 'point-at-eol
- 'line-end-position))
+ (if (fboundp 'point-at-eol)
+ (defalias 'hashcash-point-at-eol 'point-at-eol)
+ (defalias 'hashcash-point-at-eol 'line-end-position)))
(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)))
+ (if (and addr (string-match "\\`\\([^+@]+\\)\\+[^@]*\\(@.+\\)" addr))
+ (concat (match-string 1 addr) (match-string 2 addr))
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)))
+ (or (nth 2 val) (nth 1 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)))
+ (or (nth 1 val) (nth 0 val) addr)))
(defun hashcash-generate-payment (str val)
"Generate a hashcash payment by finding a VAL-bit collison on STR."
(save-excursion
(set-buffer (get-buffer-create " *hashcash*"))
(erase-buffer)
- (call-process hashcash nil t nil (concat "-b " (number-to-string val))
- str)
+ (call-process hashcash-path nil t nil
+ "-m" "-q" "-b" (number-to-string val) str)
(goto-char (point-min))
(buffer-substring (hashcash-point-at-bol) (hashcash-point-at-eol)))
nil))
(defun hashcash-check-payment (token str val)
"Check the validity of a hashcash payment."
- (zerop (call-process hashcash nil nil nil "-c"
+ (zerop (call-process hashcash-path nil nil nil "-c"
"-d" "-f" hashcash-double-spend-database
"-b" (number-to-string val)
"-r" str
token)))
+(defun hashcash-version (token)
+ "Find the format version of a hashcash token."
+ ;; Version 1.2 looks like n:yymmdd:rrrrr:xxxxxxxxxxxxxxxx
+ ;; This carries its own version number embedded in the token,
+ ;; so no further format number changes should be necessary
+ ;; in the X-Payment header.
+ ;;
+ ;; Version 1.1 looks like yymmdd:rrrrr:xxxxxxxxxxxxxxxx
+ ;; You need to upgrade your hashcash binary.
+ ;;
+ ;; Version 1.0 looked like nnnnnrrrrrxxxxxxxxxxxxxxxx
+ ;; This is no longer supported.
+ (cond ((equal (aref token 1) ?:) 1.2)
+ ((equal (aref token 6) ?:) 1.1)
+ (t (error "Unknown hashcash format version"))))
+
;;;###autoload
(defun hashcash-insert-payment (arg)
"Insert X-Payment and X-Hashcash headers with a payment for ARG"
(let ((pay (hashcash-generate-payment (hashcash-payment-to arg)
(hashcash-payment-required arg))))
(when pay
- (insert-before-markers "X-Payment: hashcash 1.1 " pay "\n")
+; (insert-before-markers "X-Payment: hashcash "
+; (number-to-string (hashcash-version pay)) " "
+; pay "\n")
(insert-before-markers "X-Hashcash: " pay "\n"))))
;;;###autoload
(defun hashcash-verify-payment (token &optional resource amount)
"Verify a hashcash payment"
- (let ((key (cadr (split-string-by-char token ?:))))
+ (let ((key (if (< (hashcash-version token) 1.2)
+ (nth 1 (split-string token ":"))
+ (nth 2 (split-string token ":")))))
(cond ((null resource)
(let ((elt (assoc key hashcash-accept-resources)))
(and elt (hashcash-check-payment token (car elt)
(when (and hashcash-in-news ng)
(setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*")))))
(when addrlist
- (mapc #'hashcash-insert-payment addrlist)))))
+ (mapcar #'hashcash-insert-payment addrlist))))) ; mapc
t)
;;;###autoload
Prefix arg sets default accept amount temporarily."
(interactive "P")
(let ((hashcash-default-accept-payment (if arg (prefix-numeric-value arg)
- hashcash-default-accept-payment)))
+ hashcash-default-accept-payment))
+ (version (hashcash-version (hashcash-generate-payment "x" 1))))
(save-excursion
(goto-char (point-min))
- (search-forward mail-header-separator)
+ (search-forward "\n\n")
(beginning-of-line)
(let ((end (point))
(ok nil))
(goto-char (point-min))
- (while (and (not ok) (search-forward "X-Payment: hashcash 1.1 " end t))
- (setq ok (hashcash-verify-payment
- (buffer-substring (point) (hashcash-point-at-eol)))))
+ (while (and (not ok) (search-forward "X-Payment: hashcash " end t))
+ (let ((value (split-string
+ (buffer-substring (point) (hashcash-point-at-eol))
+ " ")))
+ (when (equal (car value) (number-to-string version))
+ (setq ok (hashcash-verify-payment (cadr value))))))
(goto-char (point-min))
(while (and (not ok) (search-forward "X-Hashcash: " end t))
(setq ok (hashcash-verify-payment
ok))))
(provide 'hashcash)
-
-;;; hashcash.el ends here