From 853f3e9e91420203737999a44e7e5427b45ad977 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 22 May 2000 20:22:52 +0000 Subject: [PATCH] Move pass-phrase memoization into the front end. Now connections to the same account on the same server can share a pass phrase. --- v7/src/imail/imail-core.scm | 8 ++++- v7/src/imail/imail-file.scm | 7 ++++- v7/src/imail/imail-imap.scm | 60 ++++++++----------------------------- v7/src/imail/imail-top.scm | 55 +++++++++++++++++++++++++++++----- v7/src/imail/todo.txt | 10 ++----- 5 files changed, 74 insertions(+), 66 deletions(-) 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-exists? (file-url-pathname url))) +(define-method url-pass-phrase-key ((url )) + ;; Unused + url + "") + (define (define-file-url-completers class filter) (define-method %url-complete-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 )) + (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 ( (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 ( (constructor (url connection))) () @@ -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. -- 2.25.1