diff --git a/collects/version/check.ss b/collects/version/check.ss index 4ada621ee2..cbb9045d71 100644 --- a/collects/version/check.ss +++ b/collects/version/check.ss @@ -1,107 +1,107 @@ -(module check mzscheme +#lang scheme/base - (define version-url "http://download.plt-scheme.org/version") - (define timeout 30) +(define version-url "http://download.plt-scheme.org/version") +(define timeout 30) - ;; This file is invoked from the installer, without using zo files -- so - ;; using net/url.ss is extremely slow. Instead, do things directly. - ;; (require net/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) +;; This file can be invoked from an installer, and in case it's +;; without zo files using net/url.ss is extremely slow. Instead, do +;; things directly. +;; (require net/url) +;; (define (url->port url) (get-pure-port (string->url url))) - (define error-value - (case-lambda - [(what) `(error ,what)] - [(what more) - `(error ,what - ,(cond [(list? more) (format "~a" more)] - [(exn? more) (format "(~a)" (exn-message more))] - [else (format "(~a)" more)]))])) +(require scheme/tcp) +(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 (with-timeout timeout thunk) - (define result #f) - (let ([r (sync/timeout timeout - (thread (lambda () - (set! result - (with-handlers - ([void (lambda (e) - (error-value "internal error" e))]) - (thunk))))))]) - (if r result (error-value "timeout")))) +(define error-value + (case-lambda + [(what) `(error ,what)] + [(what more) + `(error ,what + ,(cond [(list? more) (format "~a" more)] + [(exn? more) (format "(~a)" (exn-message more))] + [else (format "(~a)" more)]))])) - (define (check-version/timeout) - (let/ec escape - (define (err . args) (escape (apply error-value args))) - (define-syntax try - (syntax-rules () - [(_ expr error-message) - (with-handlers ([void (lambda (e) (err error-message e))]) expr)])) - ;; Get server information, carefully - (define version-info - (parameterize ([current-input-port - (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)])))) +(define (with-timeout timeout thunk) + (define result #f) + (let ([r (sync/timeout timeout + (thread (lambda () + (set! result + (with-handlers + ([void (lambda (e) + (error-value "internal error" e))]) + (thunk))))))]) + (if r result (error-value "timeout")))) - ;; 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/timeout)) +(define (check-version-raw) + (let/ec escape + (define (err . args) (escape (apply error-value args))) + (define-syntax try + (syntax-rules () + [(_ expr error-message) + (with-handlers ([void (lambda (e) (err error-message e))]) expr)])) + ;; Get server information, carefully + (define version-info + (parameterize ([current-input-port + (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. 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))