Re: Asynchronous hashcash.el

[Magnus Henoch <mange@freemail.hu>]

[-- Attachment #1: Type: text/plain, Size: 164 bytes --]

Simon Josefsson <jas@extundo.com> writes:

> Magnus, do you have an updated version?  I'd be happy to install it.

Yes, finally got around to do it... here it is:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: gnus-hashcash.patch --]
[-- Type: text/x-patch, Size: 9195 bytes --]

* looking for miles@gnu.org--gnu-2004/gnus--devo--0--patch-169 to compare with
* comparing to miles@gnu.org--gnu-2004/gnus--devo--0--patch-169
M  lisp/hashcash.el
M  lisp/message.el
M  texi/gnus.texi

* modified files

--- orig/lisp/hashcash.el
+++ mod/lisp/hashcash.el
@@ -30,15 +30,29 @@
 ;; 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:
+;; Call mail-add-payment-async after writing the addresses but before
+;; writing the mail to start calculating the hashcash payment
+;; asynchronously.
+;;
+;; The easiest way to do this automatically for all outgoing mail
+;; is to set `message-generate-hashcash' to t.  If you want more
+;; control, try the following hooks.
+;;
+;; To automatically add payments to all outgoing mail when sending:
 ;;    (add-hook 'message-send-hook 'mail-add-payment)
+;;
+;; To start calculations automatically when addresses are prefilled:
+;;    (add-hook 'message-setup-hook 'mail-add-payment-async)
+;;
+;; To check whether calculations are done before sending:
+;;    (add-hook 'message-send-hook 'hashcash-wait-or-cancel)
 
 ;;; Code:
 
 (eval-and-compile
  (autoload 'executable-find "executable"))
 
-(defcustom hashcash-default-payment 10
+(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'."
@@ -51,7 +65,7 @@
 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.")
 
-(defcustom hashcash-default-accept-payment 10
+(defcustom hashcash-default-accept-payment 20
   "*The default minimum number of bits to accept on incoming payments."
   :type 'integer)
 
@@ -71,6 +85,9 @@
   "*Specifies whether or not hashcash payments should be made to newsgroups."
   :type 'boolean)
 
+(defvar hashcash-process-alist nil
+  "Alist of asynchronous hashcash processes and buffers.")
+
 (require 'mail-utils)
 
 (eval-and-compile
@@ -122,6 +139,19 @@
 	(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)))
+	(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)))
+
 (defun hashcash-check-payment (token str val)
   "Check the validity of a hashcash payment."
   (if hashcash-path
@@ -151,17 +181,87 @@
 	((equal (aref token 6) ?:) 1.1)
 	(t (error "Unknown hashcash format version"))))
 
+(defun hashcash-already-paid-p (recipient)
+  "Check for hashcash token to RECIPIENT in current buffer."
+  (save-excursion
+    (save-restriction
+      (message-narrow-to-headers-or-head)
+      (let ((token (message-fetch-field "x-hashcash")))
+	(and (stringp token)
+	     (string-match (regexp-quote recipient) token))))))
+
 ;;;###autoload
 (defun hashcash-insert-payment (arg)
   "Insert X-Payment and X-Hashcash headers with a payment for ARG"
   (interactive "sPay to: ")
-  (let ((pay (hashcash-generate-payment (hashcash-payment-to arg)
-					(hashcash-payment-required arg))))
-    (when pay
+  (unless (hashcash-already-paid-p arg)
+    (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
+(defun hashcash-insert-payment-async (arg)
+  "Insert X-Payment and X-Hashcash headers with a payment for ARG
+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)))))
+
+(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 "\n"))))
+	  (insert-before-markers "X-Hashcash: " pay))))))
+
+(defun hashcash-cancel-async (&optional buffer)
+  "Delete any hashcash processes associated with BUFFER.
+BUFFER defaults to the current buffer."
+  (interactive)
+  (unless buffer (setq buffer (current-buffer)))
+  (let (entry)
+    (while (setq entry (rassq buffer hashcash-process-alist))
+      (delete-process (car entry))
+      (setq hashcash-process-alist
+	    (delq entry hashcash-process-alist)))))
+
+(defun hashcash-wait-async (&optional buffer)
+  "Wait for asynchronous hashcash processes in BUFFER to finish.
+BUFFER defaults to the current buffer."
+  (interactive)
+  (unless buffer (setq buffer (current-buffer)))
+  (let (entry)
+    (while (setq entry (rassq buffer hashcash-process-alist))
+      (accept-process-output (car entry)))))
+
+(defun hashcash-processes-running-p (buffer)
+  "Return non-nil if hashcash processes in BUFFER are still running."
+  (rassq buffer hashcash-process-alist))
+
+(defun hashcash-wait-or-cancel ()
+  "Ask user whether to wait for hashcash processes to finish."
+  (interactive)
+  (when (hashcash-processes-running-p (current-buffer))
+    (if (y-or-n-p 
+	  "Hashcash process(es) still running; wait for them to finish? ")
+	(hashcash-wait-async)
+      (hashcash-cancel-async))))
 
 ;;;###autoload
 (defun hashcash-verify-payment (token &optional resource amount)
@@ -182,9 +282,11 @@
 	  (t nil))))
 
 ;;;###autoload
-(defun mail-add-payment (&optional arg)
+(defun mail-add-payment (&optional arg async)
   "Add X-Payment: and X-Hashcash: headers with a hashcash payment
-for each recipient address.  Prefix arg sets default payment temporarily."
+for each recipient address.  Prefix arg sets default payment temporarily.
+Set ASYNC to t to start asynchronous calculation.  (See
+`mail-add-payment-async')."
   (interactive "P")
   (let ((hashcash-default-payment (if arg (prefix-numeric-value arg)
 				    hashcash-default-payment))
@@ -206,10 +308,21 @@
 	  (when (and hashcash-in-news ng)
 	    (setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*")))))
 	(when addrlist
-	  (mapcar #'hashcash-insert-payment addrlist))))) ; mapc
+	  (mapcar (if async
+		      #'hashcash-insert-payment-async
+		    #'hashcash-insert-payment)
+		  addrlist))))) ; mapc
   t)
 
 ;;;###autoload
+(defun mail-add-payment-async (&optional arg)
+  "Add X-Payment: and X-Hashcash: headers with a hashcash payment
+for each recipient address.  Prefix arg sets default payment temporarily.
+Calculation is asynchronous."
+  (interactive "P")
+  (mail-add-payment arg t))
+
+;;;###autoload
 (defun mail-check-payment (&optional arg)
   "Look for a valid X-Payment: or X-Hashcash: header.
 Prefix arg sets default accept amount temporarily."


--- orig/lisp/message.el
+++ mod/lisp/message.el
@@ -3760,10 +3760,11 @@
 	    message-posting-charset))
 	 (headers message-required-mail-headers))
     (when message-generate-hashcash
-      (save-restriction
-	(message-narrow-to-headers)
-	(message-remove-header "X-Hashcash"))
       (message "Generating hashcash...")
+      ;; Wait for calculations already started to finish...
+      (hashcash-wait-async)
+      ;; ...and do calculations not already done.  mail-add-payment
+      ;; will leave existing X-Hashcash headers alone.
       (mail-add-payment)
       (message "Generating hashcash...done"))
     (save-restriction
@@ -5582,6 +5583,9 @@
     (run-hooks 'message-header-setup-hook))
   (set-buffer-modified-p nil)
   (setq buffer-undo-list nil)
+  (when message-generate-hashcash
+    ;; Generate hashcash headers for recipients already known
+    (mail-add-payment-async))
   (run-hooks 'message-setup-hook)
   (message-position-point)
   (undo-boundary))


--- orig/texi/gnus.texi
+++ mod/texi/gnus.texi
@@ -22509,8 +22509,8 @@
 @item hashcash-default-payment
 @vindex hashcash-default-payment
 This variable indicates the default number of bits the hash collision
-should consist of.  By default this is 10, which is a rather low
-value.  Suggested useful values include 17 to 29.
+should consist of.  By default this is 20.  Suggested useful values
+include 17 to 29.
 
 @item hashcash-payment-alist
 @vindex hashcash-payment-alist




[-- Attachment #3: Type: text/plain, Size: 1092 bytes --]


After I implemented message-generate-hashcash, it turned out that the
manual needed almost no changes.

Here is the changelog:

2004-11-14  Magnus Henoch  <mange@freemail.hu>

	* hashcash.el (hashcash-default-payment): Change default to 20
	(hashcash-default-accept-payment): Change default to 20
	(hashcash-process-alist): New variable
	(hashcash-generate-payment-async): Add
	(hashcash-already-paid-p): Add
	(hashcash-insert-payment): Don't generate payments twice
	(hashcash-insert-payment-async): Add
	(hashcash-insert-payment-async-2): Add
	(hashcash-cancel-async): Add
	(hashcash-wait-async): Add
	(hashcash-processes-running-p): Add
	(hashcash-wait-or-cancel): Add
	(mail-add-payment): New optional argument.  Conditionally start
	asynchronous calculation.
	(mail-add-payment-async): Add

	* message.el (message-send-mail): Wait for asynchronous hashcash
	results.  Don't clobber existing X-Hashcash headers.
	(message-setup-1): Call mail-add-payment-async when
	message-generate-hashcash is non-nil.

	* gnus.texi (Hashcash): New default value of
	hashcash-default-payment.
	
Magnus