diff --git a/collects/handin-client/client-gui.ss b/collects/handin-client/client-gui.ss index 6082008c44..b99820e8e1 100644 --- a/collects/handin-client/client-gui.ss +++ b/collects/handin-client/client-gui.ss @@ -268,14 +268,17 @@ (center) (show #t))) + (provide manage-handin-dialog%) (define manage-handin-dialog% - (class dialog% (init [parent #f] [user-fields #f]) + (class dialog% (init [parent #f]) (inherit show is-shown? center) (super-new [label manage-dialog-name] [alignment '(left center)] [parent parent]) + (define user-fields (get-user-fields parent)) + (define status (new message% [label (if user-fields @@ -568,13 +571,50 @@ (center) (show #t))) - (provide manage-handin-account) - (define (manage-handin-account parent) - (new manage-handin-dialog% - [parent parent] - [user-fields (cond [(with-handlers ([void (lambda (_) #f)]) (connect)) - => retrieve-user-fields] - [else #f])])) + ;; A simple dialog during connection, with an option to cancel (used + ;; by `get-user-fields' below, since its value is needed to + ;; construct the above dialog). + (define connection-dialog% + (class dialog% (init receiver [parent #f]) + (inherit show is-shown? center) + (super-new [label manage-dialog-name] + [alignment '(right center)] + [parent parent]) + (define status + (new message% [label "Connecting to server..."] + [parent this] + [stretchable-width #t])) + (define comm-cust (make-custodian)) + (define/augment (on-close) + (inner (void) on-close) + (custodian-shutdown-all comm-cust)) + (define button + (new button% [label "Cancel"] [parent this] + [callback (lambda (b e) + (custodian-shutdown-all comm-cust) + (show #f))] + [style '(border)])) + (send button focus) + (parameterize ([current-custodian comm-cust]) + (thread + (lambda () + (unless (with-handlers ([void (lambda (_) #f)]) + (receiver (connect)) #t) + (begin (send status set-label "Connection failure!") + ;; (send button enable #f) + (sleep 5))) + (queue-callback (lambda () (show #f)))))) + (center) + (show #t))) + + (define cached-user-fields #f) + (define (get-user-fields parent) + (unless cached-user-fields + (new connection-dialog% + [receiver (lambda (h) + (set! cached-user-fields (retrieve-user-fields h)))] + [parent parent])) + cached-user-fields) (define (scale-by-half file) (let* ([bm (make-object bitmap% file 'unknown/mask)] diff --git a/collects/handin-client/handin-multi.ss b/collects/handin-client/handin-multi.ss index 00cf16a4e9..ce234bd7cd 100644 --- a/collects/handin-client/handin-multi.ss +++ b/collects/handin-client/handin-multi.ss @@ -116,7 +116,7 @@ [stretchable-width #t] [callback callback]))]) (button "&Submit" (lambda _ (do-submit))) (button "&Retrieve" (lambda _ (do-retrieve))) - (button "A&ccount" (lambda _ (manage-handin-account this))) + (button "A&ccount" (lambda _ (new manage-handin-dialog% [parent this]))) (when update (button "&Update" (lambda _ (update this #t)))) (button "C&lose" (lambda _ (close))))