suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

catch networking errors and show a dialog

Browse Source 
that doesn't say "internal error"

closes PR 14254
This commit is contained in:
Robby Findler 2013-12-15 21:18:20 -06:00
parent ef6af9c47c
commit 4a7c36e96e
2 changed files with 95 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
pkgs/drracket-pkgs/drracket/drracket/private/frame.rkt
View File

@ -536,86 +536,97 @@
;; install-plt-from-url : string (union #f dialog%) -> void ;; install-plt-from-url : string (union #f dialog%) -> void
;; downloads and installs a .plt file from the given url ;; downloads and installs a .plt file from the given url
(define (install-plt-from-url s-url parent) (define (install-plt-from-url s-url parent)
(define-values (port size) (define url (string->url s-url))
(let-values ([(port header) (define-values (port header)
(get-pure-port/headers (string->url s-url) (with-handlers ([exn:fail? (λ (x) (values #f x))])
#:redirections 5)]) (get-pure-port/headers url #:redirections 5)))
(define size (cond
(let* ([content-header (extract-field "content-length" header)] [port
[m (and content-header (define size
(regexp-match "[0-9]+" content-header))]) (let* ([content-header (extract-field "content-length" header)]
(and m (string->number (car m))))) [m (and content-header
(values port size))) (regexp-match "[0-9]+" content-header))])
(let* ([tmp-filename (make-temporary-file "tmp~a.plt")] (and m (string->number (car m)))))
[header (purify-port port)] (define tmp-filename (make-temporary-file "tmp~a.plt"))
[d (make-object dialog% (string-constant downloading) parent)] (define header (purify-port port))
[message (make-object message% (string-constant downloading-file...) d)] (define d (make-object dialog% (string-constant downloading) parent))
[gauge (if size (define message (make-object message% (string-constant downloading-file...) d))
(make-object gauge% #f 100 d) (define gauge (if size
#f)] (make-object gauge% #f 100 d)
[exn #f] #f))
; Semaphores to avoid race conditions: (define exn #f)
[wait-to-start (make-semaphore 0)] ; Semaphores to avoid race conditions:
[wait-to-break (make-semaphore 0)] (define wait-to-start (make-semaphore 0))
; Thread to perform the download: (define wait-to-break (make-semaphore 0))
[t (thread ; Thread to perform the download:
(λ () (define t
(semaphore-wait wait-to-start) (thread
(with-handlers ([exn:fail? (λ ()
(λ (x) (semaphore-wait wait-to-start)
(set! exn x))] (with-handlers ([exn:fail?
[exn:break? ; throw away break exceptions (λ (x)
void]) (set! exn x))]
(semaphore-post wait-to-break) [exn:break? ; throw away break exceptions
(with-output-to-file tmp-filename void])
(λ () (semaphore-post wait-to-break)
(let loop ([total 0]) (with-output-to-file tmp-filename
(when gauge (λ ()
(send gauge set-value (let loop ([total 0])
(inexact->exact (when gauge
(floor (* 100 (/ total size)))))) (send gauge set-value
(let ([s (read-string 1024 port)]) (inexact->exact
(unless (eof-object? s) (floor (* 100 (/ total size))))))
(unless (eof-object? s) (let ([s (read-string 1024 port)])
(display s) (unless (eof-object? s)
(loop (+ total (string-length s)))))))) (unless (eof-object? s)
#:mode 'binary #:exists 'truncate)) (display s)
(send d show #f)))]) (loop (+ total (string-length s))))))))
(send d center) #:mode 'binary #:exists 'truncate))
(make-object button% (string-constant &stop) (send d show #f))))
d (send d center)
(λ (b e) (make-object button% (string-constant &stop)
(semaphore-wait wait-to-break) d
(set! tmp-filename #f) (λ (b e)
(send d show #f) (semaphore-wait wait-to-break)
(break-thread t))) (set! tmp-filename #f)
; Let thread run only after the dialog is shown (send d show #f)
(queue-callback (λ () (semaphore-post wait-to-start))) (break-thread t)))
(send d show #t) ; Let thread run only after the dialog is shown
(when exn (raise exn)) (queue-callback (λ () (semaphore-post wait-to-start)))
(define unpack-err (open-output-string)) (send d show #t)
(cond (when exn (raise exn))
[(with-handlers ((exn:fail? values)) (define unpack-err (open-output-string))
(parameterize ([error-display-handler drracket:init:original-error-display-handler] (cond
[current-error-port unpack-err]) [(with-handlers ((exn:fail? values))
(fold-plt-archive tmp-filename void void void void void)) (parameterize ([error-display-handler drracket:init:original-error-display-handler]
#f) [current-error-port unpack-err])
=> (fold-plt-archive tmp-filename void void void void void))
(λ (exn) #f)
(delete-file tmp-filename) =>
(message-box (string-constant drscheme) (λ (exn)
(string-append (delete-file tmp-filename)
(string-constant install-plt-error-header) (message-box (string-constant drscheme)
"\n\n" (string-append
(exn-message exn) (string-constant install-plt-error-header)
"\n\n" "\n\n"
(get-output-string unpack-err)) (exn-message exn)
#:dialog-mixin frame:focus-table-mixin))] "\n\n"
[else (get-output-string unpack-err))
(parameterize ([error-display-handler drracket:init:original-error-display-handler]) #:dialog-mixin frame:focus-table-mixin))]
(run-installer tmp-filename [else
(λ () (parameterize ([error-display-handler drracket:init:original-error-display-handler])
(delete-file tmp-filename))))]))) (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% (define keybindings-frame%
(class frame% (class frame%

3
pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
View File

@ -462,6 +462,9 @@ please adhere to these guidelines:
(install-plt-file-tab "File") (install-plt-file-tab "File")
(install-plt-filename "Filename:") (install-plt-filename "Filename:")
(install-plt-url "URL:") (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-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 when opened in drscheme strings