From 4a7c36e96ec022d7345ca83bd10fe2125d4899bf Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 15 Dec 2013 21:18:20 -0600 Subject: [PATCH] catch networking errors and show a dialog that doesn't say "internal error" closes PR 14254 --- .../drracket/drracket/private/frame.rkt | 173 ++++++++++-------- .../private/english-string-constants.rkt | 3 + 2 files changed, 95 insertions(+), 81 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/frame.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/frame.rkt index 9b6d80d235..85972179a1 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/frame.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/frame.rkt @@ -225,7 +225,7 @@ '()))))) (define/override (on-subwindow-char receiver event) - (define user-key? (send (keymap:get-user) + (define user-key? (send (keymap:get-user) handle-key-event (if (is-a? receiver editor-canvas%) (send receiver get-editor) @@ -536,86 +536,97 @@ ;; install-plt-from-url : string (union #f dialog%) -> void ;; downloads and installs a .plt file from the given url (define (install-plt-from-url s-url parent) - (define-values (port size) - (let-values ([(port header) - (get-pure-port/headers (string->url s-url) - #:redirections 5)]) - (define size - (let* ([content-header (extract-field "content-length" header)] - [m (and content-header - (regexp-match "[0-9]+" content-header))]) - (and m (string->number (car m))))) - (values port size))) - (let* ([tmp-filename (make-temporary-file "tmp~a.plt")] - [header (purify-port port)] - [d (make-object dialog% (string-constant downloading) parent)] - [message (make-object message% (string-constant downloading-file...) d)] - [gauge (if size - (make-object gauge% #f 100 d) - #f)] - [exn #f] - ; Semaphores to avoid race conditions: - [wait-to-start (make-semaphore 0)] - [wait-to-break (make-semaphore 0)] - ; Thread to perform the download: - [t (thread - (λ () - (semaphore-wait wait-to-start) - (with-handlers ([exn:fail? - (λ (x) - (set! exn x))] - [exn:break? ; throw away break exceptions - void]) - (semaphore-post wait-to-break) - (with-output-to-file tmp-filename - (λ () - (let loop ([total 0]) - (when gauge - (send gauge set-value - (inexact->exact - (floor (* 100 (/ total size)))))) - (let ([s (read-string 1024 port)]) - (unless (eof-object? s) - (unless (eof-object? s) - (display s) - (loop (+ total (string-length s)))))))) - #:mode 'binary #:exists 'truncate)) - (send d show #f)))]) - (send d center) - (make-object button% (string-constant &stop) - d - (λ (b e) - (semaphore-wait wait-to-break) - (set! tmp-filename #f) - (send d show #f) - (break-thread t))) - ; Let thread run only after the dialog is shown - (queue-callback (λ () (semaphore-post wait-to-start))) - (send d show #t) - (when exn (raise exn)) - (define unpack-err (open-output-string)) - (cond - [(with-handlers ((exn:fail? values)) - (parameterize ([error-display-handler drracket:init:original-error-display-handler] - [current-error-port unpack-err]) - (fold-plt-archive tmp-filename void void void void void)) - #f) - => - (λ (exn) - (delete-file tmp-filename) - (message-box (string-constant drscheme) - (string-append - (string-constant install-plt-error-header) - "\n\n" - (exn-message exn) - "\n\n" - (get-output-string unpack-err)) - #:dialog-mixin frame:focus-table-mixin))] - [else - (parameterize ([error-display-handler drracket:init:original-error-display-handler]) - (run-installer tmp-filename - (λ () - (delete-file tmp-filename))))]))) + (define url (string->url s-url)) + (define-values (port header) + (with-handlers ([exn:fail? (λ (x) (values #f x))]) + (get-pure-port/headers url #:redirections 5))) + (cond + [port + (define size + (let* ([content-header (extract-field "content-length" header)] + [m (and content-header + (regexp-match "[0-9]+" content-header))]) + (and m (string->number (car m))))) + (define tmp-filename (make-temporary-file "tmp~a.plt")) + (define header (purify-port port)) + (define d (make-object dialog% (string-constant downloading) parent)) + (define message (make-object message% (string-constant downloading-file...) d)) + (define gauge (if size + (make-object gauge% #f 100 d) + #f)) + (define exn #f) + ; Semaphores to avoid race conditions: + (define wait-to-start (make-semaphore 0)) + (define wait-to-break (make-semaphore 0)) + ; Thread to perform the download: + (define t + (thread + (λ () + (semaphore-wait wait-to-start) + (with-handlers ([exn:fail? + (λ (x) + (set! exn x))] + [exn:break? ; throw away break exceptions + void]) + (semaphore-post wait-to-break) + (with-output-to-file tmp-filename + (λ () + (let loop ([total 0]) + (when gauge + (send gauge set-value + (inexact->exact + (floor (* 100 (/ total size)))))) + (let ([s (read-string 1024 port)]) + (unless (eof-object? s) + (unless (eof-object? s) + (display s) + (loop (+ total (string-length s)))))))) + #:mode 'binary #:exists 'truncate)) + (send d show #f)))) + (send d center) + (make-object button% (string-constant &stop) + d + (λ (b e) + (semaphore-wait wait-to-break) + (set! tmp-filename #f) + (send d show #f) + (break-thread t))) + ; Let thread run only after the dialog is shown + (queue-callback (λ () (semaphore-post wait-to-start))) + (send d show #t) + (when exn (raise exn)) + (define unpack-err (open-output-string)) + (cond + [(with-handlers ((exn:fail? values)) + (parameterize ([error-display-handler drracket:init:original-error-display-handler] + [current-error-port unpack-err]) + (fold-plt-archive tmp-filename void void void void void)) + #f) + => + (λ (exn) + (delete-file tmp-filename) + (message-box (string-constant drscheme) + (string-append + (string-constant install-plt-error-header) + "\n\n" + (exn-message exn) + "\n\n" + (get-output-string unpack-err)) + #:dialog-mixin frame:focus-table-mixin))] + [else + (parameterize ([error-display-handler drracket:init:original-error-display-handler]) + (run-installer tmp-filename + (λ () + (delete-file tmp-filename))))])] + [else + (define exn header) + (define sp (open-output-string)) + (parameterize ([current-error-port sp]) + (drracket:init:original-error-display-handler (exn-message exn) exn)) + (message-box (string-constant drracket) + (string-append + (string-constant install-plt-error-downloading) + (get-output-string sp)))])) (define keybindings-frame% (class frame% diff --git a/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt b/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt index 9fa39cb8e1..1bb7db98ce 100644 --- a/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt +++ b/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt @@ -462,6 +462,9 @@ please adhere to these guidelines: (install-plt-file-tab "File") (install-plt-filename "Filename:") (install-plt-url "URL:") + ; an error message from a primitive operation is appended to the end of this message. + (install-plt-error-downloading "There was an error when downloading the" + " .plt file.\n\nDetails:\n") (install-plt-error-header "There was an error when checking the validity of the downloaded .plt file. Please check the url and try again.") ;; install plt file when opened in drscheme strings