;;; hashcash.el --- Add hashcash payments to email
-;; Copyright (C) 2003, 2004 Free Software Foundation
-;; Copyright (C) 1997--2002 Paul E. Foley
+;; Copyright (C) 2003, 2004, 2005 Free Software Foundation
+;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002)
;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
;; Keywords: mail, hashcash
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
-(eval-and-compile
- (autoload 'executable-find "executable"))
+(defgroup hashcash nil
+ "Hashcash configuration."
+ :group 'mail)
(defcustom hashcash-default-payment 20
"*The default number of bits to pay to unknown users.
If this is zero, no payment header will be generated.
See `hashcash-payment-alist'."
- :type 'integer)
+ :type 'integer
+ :group 'hashcash)
(defcustom hashcash-payment-alist '()
"*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.")
+present, is the string to be hashed; if not present ADDR will be used."
+ :type '(repeat (choice (list :tag "Normal"
+ (string :name "Address")
+ (integer :name "Amount"))
+ (list :tag "Replace hash input"
+ (string :name "Address")
+ (string :name "Hash input")
+ (integer :name "Amount"))))
+ :group 'hashcash)
(defcustom hashcash-default-accept-payment 20
"*The default minimum number of bits to accept on incoming payments."
- :type 'integer)
+ :type 'integer
+ :group 'hashcash)
(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.")
+is used instead."
+ :group 'hashcash)
(defcustom hashcash-path (executable-find "hashcash")
- "*The path to the hashcash binary.")
+ "*The path to the hashcash binary."
+ :group 'hashcash)
+
+(defcustom hashcash-extra-generate-parameters nil
+ "*A list of parameter strings passed to `hashcash-path' when minting.
+For example, you may want to set this to '(\"-Z2\") to reduce header length."
+ :type '(repeat string)
+ :group 'hashcash)
(defcustom hashcash-double-spend-database "hashcash.db"
- "*The path to the double-spending database.")
+ "*The path to the double-spending database."
+ :group 'hashcash)
(defcustom hashcash-in-news nil
"*Specifies whether or not hashcash payments should be made to newsgroups."
- :type 'boolean)
+ :type 'boolean
+ :group 'hashcash)
(defvar hashcash-process-alist nil
"Alist of asynchronous hashcash processes and buffers.")
(save-excursion
(set-buffer (get-buffer-create " *hashcash*"))
(erase-buffer)
- (call-process hashcash-path nil t nil
- "-m" "-q" "-b" (number-to-string val) str)
+ (apply 'call-process hashcash-path nil t nil
+ "-m" "-q" "-b" (number-to-string val) str
+ hashcash-extra-generate-parameters)
(goto-char (point-min))
(hashcash-token-substring))
(error "No `hashcash' binary found")))
"Generate a hashcash payment by finding a VAL-bit collison on STR.
Return immediately. Call CALLBACK with process and result when ready."
(if (> val 0)
- (let ((process (start-process "hashcash" nil
- hashcash-path "-m" "-q" "-b" (number-to-string val) str)))
+ (let ((process (apply 'start-process "hashcash" nil
+ hashcash-path "-m" "-q"
+ "-b" (number-to-string val) str
+ hashcash-extra-generate-parameters)))
(setq hashcash-process-alist (cons
(cons process (current-buffer))
hashcash-process-alist))
(save-excursion
(save-restriction
(message-narrow-to-headers-or-head)
- (let ((token (message-fetch-field "x-hashcash")))
+ (let ((token (message-fetch-field "x-hashcash"))
+ (case-fold-search t))
(and (stringp token)
(string-match (regexp-quote recipient) token))))))
(let ((pay (hashcash-generate-payment (hashcash-payment-to arg)
(hashcash-payment-required arg))))
(when pay
- ;; (insert-before-markers "X-Payment: hashcash "
- ;; (number-to-string (hashcash-version pay)) " "
- ;; pay "\n")
(insert-before-markers "X-Hashcash: " pay "\n")))))
;;;###autoload
Only start calculation. Results are inserted when ready."
(interactive "sPay to: ")
(unless (hashcash-already-paid-p arg)
- (hashcash-generate-payment-async (hashcash-payment-to arg)
- (hashcash-payment-required arg)
- `(lambda (process payment)
- (hashcash-insert-payment-async-2 ,(current-buffer) process payment)))))
+ (hashcash-generate-payment-async
+ (hashcash-payment-to arg)
+ (hashcash-payment-required arg)
+ `(lambda (process payment)
+ (hashcash-insert-payment-async-2 ,(current-buffer) process payment)))))
(defun hashcash-insert-payment-async-2 (buffer process pay)
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- (setq hashcash-process-alist (delq
- (assq process hashcash-process-alist)
- hashcash-process-alist))
- (goto-char (point-min))
- (search-forward mail-header-separator)
- (beginning-of-line)
- (when pay
-;; (insert-before-markers "X-Payment: hashcash "
-;; (number-to-string (hashcash-version pay)) " "
-;; pay "\n")
- (insert-before-markers "X-Hashcash: " pay))))))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (setq hashcash-process-alist (delq
+ (assq process hashcash-process-alist)
+ hashcash-process-alist))
+ (message-goto-eoh)
+ (when pay
+ (insert-before-markers "X-Hashcash: " pay)))))))
(defun hashcash-cancel-async (&optional buffer)
"Delete any hashcash processes associated with BUFFER.
(addrlist nil))
(save-excursion
(save-restriction
- (goto-char (point-min))
- (search-forward mail-header-separator)
- (beginning-of-line)
- (narrow-to-region (point-min) (point))
+ (message-narrow-to-headers)
(let ((to (hashcash-strip-quoted-names (mail-fetch-field "To" nil t)))
(cc (hashcash-strip-quoted-names (mail-fetch-field "Cc" nil t)))
(ng (hashcash-strip-quoted-names (mail-fetch-field "Newsgroups"
projects / gnus / blobdiff