;;; hashcash.el --- Add hashcash payments to email
-;; Copyright (C) 2003, 2004 Free Software Foundation
-;; Copyright (C) 1997--2002 Paul E. Foley
+;; Copyright (C) 2003-2005, 2007-2015 Free Software Foundation, Inc.
+;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002)
;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
;; Keywords: mail, hashcash
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
-(eval-and-compile
- (autoload 'executable-find "executable"))
+(eval-when-compile (require 'cl)) ; for case
+
+(defgroup hashcash nil
+ "Hashcash configuration."
+ :group 'mail)
(defcustom hashcash-default-payment 20
- "*The default number of bits to pay to unknown users.
+ "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.
+ "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
(list :tag "Replace hash input"
(string :name "Address")
(string :name "Hash input")
- (integer :name "Amount")))))
+ (integer :name "Amount"))))
+ :group 'hashcash)
(defcustom hashcash-default-accept-payment 20
- "*The default minimum number of bits to accept on incoming payments."
- :type 'integer)
+ "The default minimum number of bits to accept on incoming payments."
+ :type 'integer
+ :group 'hashcash)
(defcustom hashcash-accept-resources `((,user-mail-address nil))
- "*An association list mapping hashcash resources to payment amounts.
+ "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-path (executable-find "hashcash")
- "*The path to the hashcash binary.")
+is used instead."
+ :type 'alist
+ :group 'hashcash)
+
+(define-obsolete-variable-alias 'hashcash-path 'hashcash-program "24.4")
+(defcustom hashcash-program "hashcash"
+ "The name of the hashcash executable.
+If this is not in your PATH, specify an absolute file name."
+ :type '(choice (const nil) file)
+ :group 'hashcash)
+
+(defcustom hashcash-extra-generate-parameters nil
+ "A list of parameter strings passed to `hashcash-program' 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 name of the double-spending database file."
+ :type 'file
+ :group 'hashcash)
(defcustom hashcash-in-news nil
- "*Specifies whether or not hashcash payments should be made to newsgroups."
- :type 'boolean)
+ "Specifies whether or not hashcash payments should be made to newsgroups."
+ :type 'boolean
+ :group 'hashcash)
(defvar hashcash-process-alist nil
"Alist of asynchronous hashcash processes and buffers.")
(require 'mail-utils)
(eval-and-compile
- (if (fboundp 'point-at-bol)
- (defalias 'hashcash-point-at-bol 'point-at-bol)
- (defalias 'hashcash-point-at-bol 'line-beginning-position))
+ (if (fboundp 'point-at-bol)
+ (defalias 'hashcash-point-at-bol 'point-at-bol)
+ (defalias 'hashcash-point-at-bol 'line-beginning-position))
- (if (fboundp 'point-at-eol)
- (defalias 'hashcash-point-at-eol 'point-at-eol)
- (defalias 'hashcash-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))
(concat (match-string 1 addr) (match-string 2 addr))
addr))
+(declare-function message-narrow-to-headers-or-head "message" ())
+(declare-function message-fetch-field "message" (header &optional not-all))
+(declare-function message-goto-eoh "message" ())
+(declare-function message-narrow-to-headers "message" ())
+
(defun hashcash-token-substring ()
(save-excursion
(let ((token ""))
(defun hashcash-generate-payment (str val)
"Generate a hashcash payment by finding a VAL-bit collison on STR."
(if (and (> val 0)
- hashcash-path)
- (save-excursion
- (set-buffer (get-buffer-create " *hashcash*"))
+ hashcash-program)
+ (with-current-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-program 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")))
(defun hashcash-generate-payment-async (str val callback)
"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)))
+ (if (and (> val 0)
+ hashcash-program)
+ (let ((process (apply 'start-process "hashcash" nil
+ hashcash-program "-m" "-q"
+ "-b" (number-to-string val) str
+ hashcash-extra-generate-parameters)))
(setq hashcash-process-alist (cons
(cons process (current-buffer))
hashcash-process-alist))
(set-process-filter process `(lambda (process output)
(funcall ,callback process output))))
- (funcall callback nil)))
+ (funcall callback nil nil)))
(defun hashcash-check-payment (token str val)
"Check the validity of a hashcash payment."
- (if hashcash-path
- (zerop (call-process hashcash-path nil nil nil "-c"
+ (if hashcash-program
+ (zerop (call-process hashcash-program nil nil nil "-c"
"-d" "-f" hashcash-double-spend-database
"-b" (number-to-string val)
"-r" str
(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.
(unless buffer (setq buffer (current-buffer)))
(let (entry)
(while (setq entry (rassq buffer hashcash-process-alist))
- (accept-process-output (car entry)))))
+ (accept-process-output (car entry) 1))))
(defun hashcash-processes-running-p (buffer)
"Return non-nil if hashcash processes in BUFFER are still running."
"Ask user whether to wait for hashcash processes to finish."
(interactive)
(when (hashcash-processes-running-p (current-buffer))
- (if (y-or-n-p
+ (if (y-or-n-p
"Hashcash process(es) still running; wait for them to finish? ")
(hashcash-wait-async)
(hashcash-cancel-async))))
(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"
(when (and hashcash-in-news ng)
(setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*")))))
(when addrlist
- (mapcar (if async
- #'hashcash-insert-payment-async
- #'hashcash-insert-payment)
- addrlist))))) ; mapc
+ (mapc (if async
+ #'hashcash-insert-payment-async
+ #'hashcash-insert-payment)
+ addrlist)))))
t)
;;;###autoload
(provide 'hashcash)
-;;; arch-tag: 0e7fe983-a124-4392-9788-0dbcbd2c4d62
+;;; hashcash.el ends here
projects / gnus / blobdiff