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

svn: r8813

Browse Source
This commit is contained in:
Eli Barzilay 2008-02-27 14:04:03 +00:00
parent 36b05ee127
commit 7a1aaadf8d
1 changed files with 100 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/version/check.ss
View File

@ -1,14 +1,16 @@
(module check mzscheme #lang scheme/base
(define version-url "http://download.plt-scheme.org/version") (define version-url "http://download.plt-scheme.org/version")
(define timeout 30) (define timeout 30)
;; This file is invoked from the installer, without using zo files -- so ;; This file can be invoked from an installer, and in case it's
;; using net/url.ss is extremely slow. Instead, do things directly. ;; without zo files using net/url.ss is extremely slow. Instead, do
;; (require net/url) ;; things directly.
;; (define (url->port url) ;; (require net/url)
;; (get-pure-port (string->url url))) ;; (define (url->port url) (get-pure-port (string->url url)))
(define (url->port url)
(require scheme/tcp)
(define (url->port url)
(define-values (host path) (define-values (host path)
(apply values (cdr (regexp-match #rx"^http://([^/:@]+)(/.*)$" url)))) (apply values (cdr (regexp-match #rx"^http://([^/:@]+)(/.*)$" url))))
(define-values (i o) (tcp-connect host 80)) (define-values (i o) (tcp-connect host 80))
@ -19,7 +21,7 @@
(error 'url->port "bad reply from server: ~a" (read-line))) (error 'url->port "bad reply from server: ~a" (read-line)))
i) i)
(define error-value (define error-value
(case-lambda (case-lambda
[(what) `(error ,what)] [(what) `(error ,what)]
[(what more) [(what more)
@ -28,7 +30,7 @@
[(exn? more) (format "(~a)" (exn-message more))] [(exn? more) (format "(~a)" (exn-message more))]
[else (format "(~a)" more)]))])) [else (format "(~a)" more)]))]))
(define (with-timeout timeout thunk) (define (with-timeout timeout thunk)
(define result #f) (define result #f)
(let ([r (sync/timeout timeout (let ([r (sync/timeout timeout
(thread (lambda () (thread (lambda ()
@ -39,7 +41,7 @@
(thunk))))))]) (thunk))))))])
(if r result (error-value "timeout")))) (if r result (error-value "timeout"))))
(define (check-version/timeout) (define (check-version-raw)
(let/ec escape (let/ec escape
(define (err . args) (escape (apply error-value args))) (define (err . args) (escape (apply error-value args)))
(define-syntax try (define-syntax try
@ -86,22 +88,20 @@
;; stable) ;; stable)
[else `(newer ,stable ,recent)])))) [else `(newer ,stable ,recent)]))))
;; Check the version on the server and compare to our version. ;; Check the version on the server and compare to our version. Possible return
;; Possible return values (message is always a string): ;; values (message is always a string):
;; * `ok ;; * `ok
;; You're fine. ;; You're fine.
;; * `(ok-but ,version) ;; * `(ok-but ,version)
;; You have a fine stable version, but note that there is a newer alpha ;; You have a fine stable version, but note that there is a newer alpha
;; * `(newer ,version) ;; * `(newer ,version)
;; You have an old version, please upgrade to `version' ;; You have an old version, please upgrade to `version'
;; * `(newer ,version ,alpha) ;; * `(newer ,version ,alpha)
;; You have an old version, please upgrade to `version' you may consider ;; You have an old version, please upgrade to `version' you may consider also
;; also the alpha version ;; the alpha version
;; * `(error ,message [,additional-info]) ;; * `(error ,message [,additional-info])
;; An error occured, the third (optional) value can be shown as the system ;; An error occured, the third (optional) value can be shown as the system
;; error that happened or the value that caused an error. ;; error that happened or the value that caused an error.
(provide check-version) (provide check-version)
(define (check-version) (define (check-version)
(with-timeout timeout check-version/timeout)) (with-timeout timeout check-version-raw))
)