the same account on the same server can share a pass phrase.
;;; -*-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
;;;
;; 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))
\f
;; 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
;;; -*-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
;;;
(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)
;;; -*-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
;;;
(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)
+ ""))
\f
(define-method parse-url-body (string default-url)
(call-with-values (lambda () (parse-imap-url-body string default-url))
(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)
(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)
(if (imap-connection-folder connection) 0 1))
(close-imap-connection connection)))
\f
-(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))))
-\f
;;;; Folder datatype
(define-class (<imap-folder> (constructor (url connection))) (<folder>)
(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)
;;; -*-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
;;;
#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
(define *imail-message-wrapper-prefix* #f)
\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))))
+\f
(define-major-mode imail read-only "IMAIL"
"IMAIL mode is used by \\[imail] for editing IMAIL files.
All normal editing commands are turned off.
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.
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.
projects / mit-scheme.git / commitdiff