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

200
collects/version/check.ss
View File

@ -1,107 +1,107 @@
(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)
(define-values (host path)
(apply values (cdr (regexp-match #rx"^http://([^/:@]+)(/.*)$" url))))
(define-values (i o) (tcp-connect host 80))
(fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" path host)
(flush-output o)
(close-output-port o)
(unless (regexp-match #rx"^HTTP/[0-9.]+ 200 OK\r\n.*?\r\n\r\n" i)
(error 'url->port "bad reply from server: ~a" (read-line)))
i)
(define error-value (require scheme/tcp)
(case-lambda (define (url->port url)
[(what) `(error ,what)] (define-values (host path)
[(what more) (apply values (cdr (regexp-match #rx"^http://([^/:@]+)(/.*)$" url))))
`(error ,what (define-values (i o) (tcp-connect host 80))
,(cond [(list? more) (format "~a" more)] (fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" path host)
[(exn? more) (format "(~a)" (exn-message more))] (flush-output o)
[else (format "(~a)" more)]))])) (close-output-port o)
(unless (regexp-match #rx"^HTTP/[0-9.]+ 200 OK\r\n.*?\r\n\r\n" i)
(error 'url->port "bad reply from server: ~a" (read-line)))
i)
(define (with-timeout timeout thunk) (define error-value
(define result #f) (case-lambda
(let ([r (sync/timeout timeout [(what) `(error ,what)]
(thread (lambda () [(what more)
(set! result `(error ,what
(with-handlers ,(cond [(list? more) (format "~a" more)]
([void (lambda (e) [(exn? more) (format "(~a)" (exn-message more))]
(error-value "internal error" e))]) [else (format "(~a)" more)]))]))
(thunk))))))])
(if r result (error-value "timeout"))))
(define (check-version/timeout) (define (with-timeout timeout thunk)
(let/ec escape (define result #f)
(define (err . args) (escape (apply error-value args))) (let ([r (sync/timeout timeout
(define-syntax try (thread (lambda ()
(syntax-rules () (set! result
[(_ expr error-message) (with-handlers
(with-handlers ([void (lambda (e) (err error-message e))]) expr)])) ([void (lambda (e)
;; Get server information, carefully (error-value "internal error" e))])
(define version-info (thunk))))))])
(parameterize ([current-input-port (if r result (error-value "timeout"))))
(try (url->port (format "~a?~a" version-url (version)))
"could not connect to website")])
(try (read) "unexpected response from server")))
(define (get key)
(cond [(assq key version-info) => cadr]
[else (err (format "no `~s' in response" key) version-info)]))
(unless (and (list? version-info)
(andmap (lambda (x)
(and (list? x)
(= 2 (length x))
(symbol? (car x))
(string? (cadr x))))
version-info))
(err "bad response from server" version-info))
;; Make a decision
(let ([current (version)]
[stable (get 'stable)]
[recent (get 'recent)])
(cond
;; we have the newest version (can be > if we have an svn build)
[(string>=? current recent) 'ok]
;; we're stable, but there's a newer version
[(string>=? current stable)
`(ok-but ,recent)]
;; new version out -- no alphas or we have an alpha => show recent
;; (also for svn builds of a stable version -- anything with ".")
[(or (equal? recent stable)
(and (regexp-match #rx"[.]" current)
;; but if we have an alpha that is older then the current
;; stable then go to the next case
(string>=? current stable)))
`(newer ,recent)]
;; new version out, we have an outdated stable, there is also an alpha
;; (alternatively, we have an alpha that is older than the current
;; stable)
[else `(newer ,stable ,recent)]))))
;; Check the version on the server and compare to our version. (define (check-version-raw)
;; Possible return values (message is always a string): (let/ec escape
;; * `ok (define (err . args) (escape (apply error-value args)))
;; You're fine. (define-syntax try
;; * `(ok-but ,version) (syntax-rules ()
;; You have a fine stable version, but note that there is a newer alpha [(_ expr error-message)
;; * `(newer ,version) (with-handlers ([void (lambda (e) (err error-message e))]) expr)]))
;; You have an old version, please upgrade to `version' ;; Get server information, carefully
;; * `(newer ,version ,alpha) (define version-info
;; You have an old version, please upgrade to `version' you may consider (parameterize ([current-input-port
;; also the alpha version (try (url->port (format "~a?~a" version-url (version)))
;; * `(error ,message [,additional-info]) "could not connect to website")])
;; An error occured, the third (optional) value can be shown as the system (try (read) "unexpected response from server")))
;; error that happened or the value that caused an error. (define (get key)
(provide check-version) (cond [(assq key version-info) => cadr]
(define (check-version) [else (err (format "no `~s' in response" key) version-info)]))
(with-timeout timeout check-version/timeout)) (unless (and (list? version-info)
(andmap (lambda (x)
(and (list? x)
(= 2 (length x))
(symbol? (car x))
(string? (cadr x))))
version-info))
(err "bad response from server" version-info))
;; Make a decision
(let ([current (version)]
[stable (get 'stable)]
[recent (get 'recent)])
(cond
;; we have the newest version (can be > if we have an svn build)
[(string>=? current recent) 'ok]
;; we're stable, but there's a newer version
[(string>=? current stable)
`(ok-but ,recent)]
;; new version out -- no alphas or we have an alpha => show recent
;; (also for svn builds of a stable version -- anything with ".")
[(or (equal? recent stable)
(and (regexp-match #rx"[.]" current)
;; but if we have an alpha that is older then the current
;; stable then go to the next case
(string>=? current stable)))
`(newer ,recent)]
;; new version out, we have an outdated stable, there is also an alpha
;; (alternatively, we have an alpha that is older than the current
;; stable)
[else `(newer ,stable ,recent)]))))
) ;; Check the version on the server and compare to our version. Possible return
;; values (message is always a string):
;; * `ok
;; You're fine.
;; * `(ok-but ,version)
;; You have a fine stable version, but note that there is a newer alpha
;; * `(newer ,version)
;; You have an old version, please upgrade to `version'
;; * `(newer ,version ,alpha)
;; You have an old version, please upgrade to `version' you may consider also
;; the alpha version
;; * `(error ,message [,additional-info])
;; An error occured, the third (optional) value can be shown as the system
;; error that happened or the value that caused an error.
(provide check-version)
(define (check-version)
(with-timeout timeout check-version-raw))