diff --git a/collects/handin-client/client-gui.ss b/collects/handin-client/client-gui.ss index 61c81a2763..99f982a7a7 100644 --- a/collects/handin-client/client-gui.ss +++ b/collects/handin-client/client-gui.ss @@ -22,7 +22,10 @@ (define handin-name (#%info-lookup 'name)) (define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f))) - (define web-address (#%info-lookup 'web-address (lambda () #f))) + (define web-address (#%info-lookup 'web-address (lambda () #f))) + + (define password-keep-minutes + (#%info-lookup 'password-keep-minutes (lambda () #f))) (define handin-dialog-name (string-append handin-name " Handin")) (define button-label/h (string-append handin-name " Handin")) @@ -44,6 +47,58 @@ (define (connect) (handin-connect server port-no)) + ;; parameter-like procedure that keeps the password cached for a few minutes + (define cached-password + (let ([passwd #f] + [timer #f]) + (define protect + (let ([s (make-semaphore 1)]) + (lambda (thunk) + (dynamic-wind (lambda () (semaphore-wait s)) + thunk + (lambda () (semaphore-post s)))))) + (case-lambda + [() passwd] + [(new) + (protect (lambda () + (when (and password-keep-minutes + (not (equal? 0) password-keep-minutes) + (not (equal? passwd new))) + (when timer (kill-thread timer)) + (set! passwd new) + (set! timer (thread + (lambda () + (sleep password-keep-minutes) + (protect (lambda () + (set! passwd #f) + (set! timer #f)))))))))]))) + ;; a password entry box that uses the one cached above + (define cached-passwd% + (class text-field% + (define cached (cached-password)) + ;; use this instead of a cached password -- to avoid copy/pastes + ;; of a password, and to hide its length + (define fake-value "CACHED PASSWD") + (define/override (get-value) + (or cached (super get-value))) + (define/override (on-focus on?) + (if on? + ;; got focus -- clear out bogus contents, if any + (when cached (send this set-value "") (set! cached #f)) + ;; lost focus -- remember a new password, or restore it + (let ([p (super get-value)]) + (cond [(and p (not (string=? "" p))) + ;; don't behave as if we have a cache: don't clear + ;; the value now, or if we get the focus later + (set! cached #f) + (cached-password p)] + [(cached-password) + => (lambda (p) + (set! cached p) + (send this set-value fake-value))])))) + (super-new [init-value (if cached fake-value "")] + [style '(single password)]))) + (provide handin-frame%) (define handin-frame% (class dialog% @@ -67,12 +122,11 @@ [parent this] [callback (lambda (t e) (activate-ok))] [stretchable-width #t])) - (define passwd (new text-field% - [label "Password:"] - [parent this] - [callback (lambda (t e) (activate-ok))] - [style '(single password)] - [stretchable-width #t])) + (define passwd (new cached-passwd% + [label "Password:"] + [parent this] + [callback (lambda (t e) (activate-ok))] + [stretchable-width #t])) (define assignment (new choice% [label "Assignment:"] [choices null] @@ -260,11 +314,15 @@ (inner (void) on-close) (do-cancel-button)) - (send ok enable #f) + (init-comm) + + (send (cond [(string=? "" (send username get-value)) username] + [(string=? "" (send passwd get-value)) passwd] + [else ok]) + focus) + (send ok enable #f) ; disable after focus possibly sent to it (send assignment enable #f) - (init-comm) - (send passwd focus) (center) (show #t))) @@ -343,7 +401,11 @@ (send old-username set-value (remembered-user)) (define old-passwd - (mk-passwd "Old Password:" old-user-box activate-change)) + (new cached-passwd% + [label "Old Password:"] + [parent old-user-box] + [callback (lambda (t e) (activate-change))] + [stretchable-width #t])) (define change-user-fields (map (lambda (f) (mk-txt (string-append f ":") old-user-box activate-change)) @@ -383,8 +445,10 @@ (map (lambda (f) (mk-txt (string-append f ":") new-user-box activate-new)) (or user-fields '()))) - (define add-passwd (mk-passwd "Password:" new-user-box activate-new)) - (define add-passwd2 (mk-passwd "Password again:" new-user-box activate-new)) + (define add-passwd + (mk-passwd "Password:" new-user-box activate-new)) + (define add-passwd2 + (mk-passwd "Password again:" new-user-box activate-new)) (define new-button (new button% [label "Add User"] [parent new-user-box] [callback (lambda (b e) diff --git a/collects/handin-client/info.ss b/collects/handin-client/info.ss index 352d47a7cf..bb0af0895e 100644 --- a/collects/handin-client/info.ss +++ b/collects/handin-client/info.ss @@ -34,6 +34,9 @@ ;(define selection-default ; suffixes to auto-choose (string or string-list) ; '("*.scm;*.ss" "*.scm;*.ss;*.txt")) + ;; Client configuration + ;(define password-keep-minutes 5) ; client remembers entered password 5 mins + (define requires '(("mred") ("openssl"))) )