From f941fe026d5435d9df8d2ec0dbb66eb9ed14bc8c Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Sun, 10 Feb 2008 10:06:51 +0000 Subject: [PATCH] Move support for temporarily stored pass-phrases into Edwin from IMAIL's front end. --- v7/src/edwin/edwin.pkg | 4 +- v7/src/edwin/prompt.scm | 90 +++++++++++++++++++++++++++++++++++++- v7/src/imail/imail-top.scm | 80 ++------------------------------- 3 files changed, 95 insertions(+), 79 deletions(-) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 7bf15b59f..dcb31d066 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.304 2008/01/30 20:02:01 cph Exp $ +$Id: edwin.pkg,v 1.305 2008/02/10 10:06:51 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -485,8 +485,10 @@ USA. (parent (edwin)) (export (edwin) call-with-confirmed-pass-phrase + call-with-stored-pass-phrase call-with-pass-phrase completion-message + delete-stored-pass-phrase edwin-command$exit-minibuffer edwin-command$exit-minibuffer-yes-or-no edwin-command$minibuffer-complete diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm index 325e22113..7c129f43b 100644 --- a/v7/src/edwin/prompt.scm +++ b/v7/src/edwin/prompt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: prompt.scm,v 1.205 2008/01/30 20:02:04 cph Exp $ +$Id: prompt.scm,v 1.206 2008/02/10 10:06:51 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -1045,4 +1045,90 @@ it is added to the front of the command history." (lambda (p2) (if (not (string=? p1 p2)) (editor-error "Pass phrases do not match.")))) - (receiver p1)))) \ No newline at end of file + (receiver p1)))) + +;;;;; Stored Pass Phrases + +(define-variable pass-phrase-retention-time + "The amount of time, in minutes, that Edwin retains pass phrases. +The pass phrase is deleted if unused for this long. +Set this to zero if you don't want pass-phrase retention." + 30 + exact-nonnegative-integer?) + +(define (call-with-stored-pass-phrase key receiver) + (let ((retention-time (ref-variable pass-phrase-retention-time #f))) + (let ((entry (hash-table/get stored-pass-phrases key #f))) + (if entry + (begin + (without-interrupts + (lambda () + (deregister-timer-event (vector-ref entry 1)) + (set-up-pass-phrase-timer! entry key retention-time))) + (call-with-unobscured-pass-phrase (vector-ref entry 0) receiver)) + (call-with-pass-phrase + (string-append "Pass phrase for " key) + (lambda (pass-phrase) + (if (> retention-time 0) + (hash-table/put! + stored-pass-phrases + key + (let ((entry + (vector (obscure-pass-phrase pass-phrase) #f #f))) + (set-up-pass-phrase-timer! entry key retention-time) + entry))) + (receiver pass-phrase))))))) + +(define (delete-stored-pass-phrase key) + (hash-table/remove! stored-pass-phrases key)) + +(define (set-up-pass-phrase-timer! entry key retention-time) + ;; A race condition can occur when the timer event is re-registered. + ;; If the previous timer event is queued but not executed before + ;; being deregistered, then it will run after the re-registration + ;; and try to delete the record. By matching on ID, the previous + ;; event sees that it has been superseded and does nothing. + (let ((id (list 'ID))) + (vector-set! entry 2 id) + (vector-set! entry 1 + (register-timer-event (* retention-time 60000) + (lambda () + (without-interrupts + (lambda () + (let ((entry (hash-table/get stored-pass-phrases key #f))) + (if (and entry (eq? (vector-ref entry 2) id)) + (hash-table/remove! stored-pass-phrases key)))))))))) + +(define stored-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)))) \ No newline at end of file diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 108f783cf..9f8712bfd 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.302 2008/01/30 20:02:10 cph Exp $ +$Id: imail-top.scm,v 1.303 2008/02/10 10:06:51 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -1910,84 +1910,12 @@ Negative argument means search in reverse." (let ((folder (message-folder message))) (and folder (imail-folder->buffer folder #f))))) - + (define (imail-ui:call-with-pass-phrase url receiver) - (let ((key (url-pass-phrase-key url)) - (retention-time (ref-variable imail-pass-phrase-retention-time #f))) - (let ((entry (hash-table/get memoized-pass-phrases key #f))) - (if entry - (begin - (without-interrupts - (lambda () - (deregister-timer-event (vector-ref entry 1)) - (set-up-pass-phrase-timer! entry key retention-time))) - (call-with-unobscured-pass-phrase (vector-ref entry 0) receiver)) - (call-with-pass-phrase - (string-append "Pass phrase for " key) - (lambda (pass-phrase) - (if (> retention-time 0) - (hash-table/put! - memoized-pass-phrases - key - (let ((entry - (vector (obscure-pass-phrase pass-phrase) #f #f))) - (set-up-pass-phrase-timer! entry key retention-time) - entry))) - (receiver pass-phrase))))))) + (call-with-stored-pass-phrase (url-pass-phrase-key url) receiver)) (define (imail-ui:delete-stored-pass-phrase url) - (hash-table/remove! memoized-pass-phrases (url-pass-phrase-key url))) - -(define (set-up-pass-phrase-timer! entry key retention-time) - ;; A race condition can occur when the timer event is re-registered. - ;; If the previous timer event is queued but not executed before - ;; being deregistered, then it will run after the re-registration - ;; and try to delete the record. By matching on ID, the previous - ;; event sees that it has been superseded and does nothing. - (let ((id (list 'ID))) - (vector-set! entry 2 id) - (vector-set! entry 1 - (register-timer-event (* retention-time 60000) - (lambda () - (without-interrupts - (lambda () - (let ((entry (hash-table/get memoized-pass-phrases key #f))) - (if (and entry (eq? (vector-ref entry 2) id)) - (hash-table/remove! memoized-pass-phrases key)))))))))) - -(define 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)))) + (delete-stored-pass-phrase (url-pass-phrase-key url))) ;;;; Navigation aids -- 2.25.1