From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 22 May 2000 20:22:52 +0000 (+0000)
Subject: Move pass-phrase memoization into the front end.  Now connections to
X-Git-Tag: 20090517-FFI~3735
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=853f3e9e91420203737999a44e7e5427b45ad977;p=mit-scheme.git

Move pass-phrase memoization into the front end.  Now connections to
the same account on the same server can share a pass phrase.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 363fca89f..054185a5d 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.85 2000/05/22 19:49:50 cph Exp $
+;;; $Id: imail-core.scm,v 1.86 2000/05/22 20:22:32 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -80,6 +80,12 @@
 
 ;; Return #T if URL represents an existing folder.
 (define-generic url-exists? (url))
+
+;; Return a string that can be used as a key to memoize a pass phrase
+;; for URL.  E.g. for IMAP this could be the URL string without the
+;; mailbox information, which would allow all URLs referring to the
+;; same user account on the same server to share a pass phrase.
+(define-generic url-pass-phrase-key (url))
 
 ;; Convert STRING to a URL.  GET-DEFAULT-URL is a procedure of one
 ;; argument that returns a URL that is used to fill in defaults if
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 729d10086..a5055bf07 100644
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.35 2000/05/22 19:49:55 cph Exp $
+;;; $Id: imail-file.scm,v 1.36 2000/05/22 20:22:37 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -39,6 +39,11 @@
 (define-method url-exists? ((url <file-url>))
   (file-exists? (file-url-pathname url)))
 
+(define-method url-pass-phrase-key ((url <file-url>))
+  ;; Unused
+  url
+  "")
+
 (define (define-file-url-completers class filter)
   (define-method %url-complete-string
       ((string <string>) (default-url class)
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index f20da48df..b6ca85b1c 100644
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.74 2000/05/22 19:49:57 cph Exp $
+;;; $Id: imail-imap.scm,v 1.75 2000/05/22 20:22:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -90,6 +90,12 @@
   (and (string=? (imap-url-user-id url1) (imap-url-user-id url2))
        (string=? (imap-url-host url1) (imap-url-host url2))
        (= (imap-url-port url1) (imap-url-port url2))))
+
+(define-method url-pass-phrase-key ((url <imap-url>))
+  (make-imap-url-string (imap-url-user-id url)
+			(imap-url-host url)
+			(imap-url-port url)
+			""))
 
 (define-method parse-url-body (string default-url)
   (call-with-values (lambda () (parse-imap-url-body string default-url))
@@ -191,7 +197,6 @@
 
 (define-class (<imap-connection> (constructor (url))) ()
   (url             define accessor)
-  (passphrase      define standard initial-value #f)
   (port            define standard initial-value #f)
   (greeting        define standard initial-value #f)
   (sequence-number define standard initial-value 0)
@@ -306,11 +311,11 @@
 		(close-imap-connection connection)
 		(error "Server doesn't support IMAP4rev1:" url)))
 	  (let ((response
-		 (call-with-memoized-passphrase connection
-		   (lambda (passphrase)
+		 (imail-call-with-pass-phrase (imap-connection-url connection)
+		   (lambda (pass-phrase)
 		     (imap:command:login connection
 					 (imap-url-user-id url)
-					 passphrase)))))
+					 pass-phrase)))))
 	    (if (imap:response:no? response)
 		(begin
 		  (close-imap-connection connection)
@@ -388,47 +393,6 @@
 	 (if (imap-connection-folder connection) 0 1))
       (close-imap-connection connection)))
 
-(define (call-with-memoized-passphrase connection receiver)
-  (let ((passphrase (imap-connection-passphrase connection)))
-    (if passphrase
-	(call-with-unobscured-passphrase passphrase receiver)
-	(imail-call-with-pass-phrase (imap-connection-url connection)
-	  (lambda (passphrase)
-	    (set-imap-connection-passphrase! connection
-					     (obscure-passphrase passphrase))
-	    (receiver passphrase))))))
-
-(define (obscure-passphrase clear-text)
-  (let ((n (string-length clear-text)))
-    (let ((noise (random-byte-vector n)))
-      (let ((obscured-text (make-string (* 2 n))))
-	(string-move! noise obscured-text 0)
-	(do ((i 0 (fix:+ i 1)))
-	    ((fix:= i n))
-	  (vector-8b-set! obscured-text (fix:+ i n)
-			  (fix:xor (vector-8b-ref clear-text i)
-				   (vector-8b-ref noise i))))
-	obscured-text))))
-
-(define (call-with-unobscured-passphrase obscured-text receiver)
-  (let ((n (quotient (string-length obscured-text) 2))
-	(clear-text))
-    (dynamic-wind
-     (lambda ()
-       (set! clear-text (make-string n))
-       unspecific)
-     (lambda ()
-       (do ((i 0 (fix:+ i 1)))
-	   ((fix:= i n))
-	 (vector-8b-set! clear-text i
-			 (fix:xor (vector-8b-ref obscured-text i)
-				  (vector-8b-ref obscured-text (fix:+ i n)))))
-       (receiver clear-text))
-     (lambda ()
-       (string-fill! clear-text #\NUL)
-       (set! clear-text)
-       unspecific))))
-
 ;;;; Folder datatype
 
 (define-class (<imap-folder> (constructor (url connection))) (<folder>)
@@ -897,10 +861,10 @@
    (imap:command:single-response imap:response:capability? connection
 				 'CAPABILITY)))
 
-(define (imap:command:login connection user-id passphrase)
+(define (imap:command:login connection user-id pass-phrase)
   ((imail-message-wrapper "Logging in as " user-id)
    (lambda ()
-     (imap:command:no-response-1 connection 'LOGIN user-id passphrase))))
+     (imap:command:no-response-1 connection 'LOGIN user-id pass-phrase))))
 
 (define (imap:command:select connection mailbox)
   ((imail-message-wrapper "Select mailbox " mailbox)
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 9b1325d38..884b60bf2 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.85 2000/05/22 19:48:23 cph Exp $
+;;; $Id: imail-top.scm,v 1.86 2000/05/22 20:22:46 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -128,13 +128,6 @@ May be called with an IMAIL folder URL as argument;
 			 #t)
 	 buffer)))))
 
-(define (imail-call-with-pass-phrase url receiver)
-  (call-with-pass-phrase (string-append "Password for user "
-					(imap-url-user-id url)
-					" on host "
-					(imap-url-host url))
-			 receiver))
-
 (define (prompt-for-imail-url-string prompt default . options)
   (apply prompt-for-completed-string
 	 prompt
@@ -219,6 +212,52 @@ May be called with an IMAIL folder URL as argument;
 
 (define *imail-message-wrapper-prefix* #f)
 
+(define (imail-call-with-pass-phrase url receiver)
+  (let ((key (url-pass-phrase-key url)))
+    (let ((obscured (hash-table/get imail-memoized-pass-phrases key #f)))
+      (if obscured
+	  (call-with-unobscured-pass-phrase obscured receiver)
+	  (call-with-pass-phrase
+	   (string-append "Pass phrase for " (url->string url))
+	   (lambda (pass-phrase)
+	     (hash-table/put! imail-memoized-pass-phrases key
+			      (obscure-pass-phrase pass-phrase))
+	     (receiver pass-phrase)))))))
+
+(define imail-memoized-pass-phrases
+  (make-string-hash-table))
+
+(define (obscure-pass-phrase clear-text)
+  (let ((n (string-length clear-text)))
+    (let ((noise (random-byte-vector n)))
+      (let ((obscured-text (make-string (* 2 n))))
+	(string-move! noise obscured-text 0)
+	(do ((i 0 (fix:+ i 1)))
+	    ((fix:= i n))
+	  (vector-8b-set! obscured-text (fix:+ i n)
+			  (fix:xor (vector-8b-ref clear-text i)
+				   (vector-8b-ref noise i))))
+	obscured-text))))
+
+(define (call-with-unobscured-pass-phrase obscured-text receiver)
+  (let ((n (quotient (string-length obscured-text) 2))
+	(clear-text))
+    (dynamic-wind
+     (lambda ()
+       (set! clear-text (make-string n))
+       unspecific)
+     (lambda ()
+       (do ((i 0 (fix:+ i 1)))
+	   ((fix:= i n))
+	 (vector-8b-set! clear-text i
+			 (fix:xor (vector-8b-ref obscured-text i)
+				  (vector-8b-ref obscured-text (fix:+ i n)))))
+       (receiver clear-text))
+     (lambda ()
+       (string-fill! clear-text #\NUL)
+       (set! clear-text)
+       unspecific))))
+
 (define-major-mode imail read-only "IMAIL"
   "IMAIL mode is used by \\[imail] for editing IMAIL files.
 All normal editing commands are turned off.
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 4b80835e5..09b1e82b4 100644
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,12 +1,9 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.37 2000/05/22 19:50:34 cph Exp $
+$Id: todo.txt,v 1.38 2000/05/22 20:22:52 cph Exp $
 
 Bug fixes
 ---------
 
-* Password should be cached s.t. it can be shared between connections
-  with compatible URLs.  Right now it is per-connection.
-
 * Login messages interfere with modeline when doing completion on IMAP
   URLs.
 
@@ -73,10 +70,7 @@ New features
   message ID can be used.  (Or perhaps no cache is required for
   non-IMAP folders.)
 
-* Password memoization should be controllable from the editor.  Should
-  this be moved into "imail-top"?  Then instead of storing the
-  password in the connection object, we could store it in a hash
-  table, or in a buffer property.
+* Password memoization should be controllable from the editor.
 
 * Implement file backup when writing file folders.