From ec6408b34358cb0097dfb7b4cbb9adc9a5cf2204 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 24 Sep 2012 14:06:31 -0500 Subject: [PATCH] Adjust the web download phase of the install .plt file menu item in drracket so that it first checks to see if the downloaded file matches a .plt archive and, if not, try to put some friendlier message in front of the gzip error closes PR 9425 closes PR 13129 --- collects/drracket/private/frame.rkt | 149 ++++++++++-------- .../private/english-string-constants.rkt | 1 + 2 files changed, 82 insertions(+), 68 deletions(-) diff --git a/collects/drracket/private/frame.rkt b/collects/drracket/private/frame.rkt index ad5a74bc9d..b7e649b6aa 100644 --- a/collects/drracket/private/frame.rkt +++ b/collects/drracket/private/frame.rkt @@ -10,7 +10,8 @@ net/head setup/plt-installer help/bug-report - racket/file) + racket/file + setup/unpack) (import [prefix drracket:unit: drracket:unit^] [prefix drracket:app: drracket:app^] @@ -473,74 +474,86 @@ ;; 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) - (with-handlers ([(λ (x) #f) - (λ (exn) - (message-box (string-constant drscheme) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn)) - #:dialog-mixin frame:focus-table-mixin))]) - (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)]) + (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) - (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)) - (parameterize ([error-display-handler drracket:init:original-error-display-handler]) - (run-installer tmp-filename - (λ () - (delete-file tmp-filename))))))) + (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 keybindings-frame% (class frame% diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 26680b8137..912223c80f 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -440,6 +440,7 @@ please adhere to these guidelines: (install-plt-file-tab "File") (install-plt-filename "Filename:") (install-plt-url "URL:") + (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 (install-plt-file "Install ~a or open for editing?")