Removed old version code, new version is greatly simplified.
svn: r1469
This commit is contained in:
Eli Barzilay
parent
6564b98863
commit
88bb2b39ee
|
|
@ -1,6 +0,0 @@
|
|||
(module check-gui mzscheme
|
||||
(require "private/gui-defs.ss" "private/go-check.ss" (lib "etc.ss"))
|
||||
(provide check-version)
|
||||
(define check-version
|
||||
(opt-lambda ([parent-frame #f] [sync? #f])
|
||||
(go-check parent-frame sync? gui-defs@))))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(module check-text mzscheme
|
||||
(require "private/text-defs.ss" "private/go-check.ss")
|
||||
(provide check-version)
|
||||
(define (check-version) (go-check #f #f text-defs@)))
|
||||
79
collects/version/check.ss
Normal file
79
collects/version/check.ss
Normal file
|
|
@ -0,0 +1,79 @@
|
|||
(module check mzscheme
|
||||
|
||||
(define version-url "http://download.plt-scheme.org/version")
|
||||
(define timeout 30)
|
||||
|
||||
(require (lib "url.ss" "net"))
|
||||
|
||||
(define (error-value what . more)
|
||||
`(error ,what ,@more))
|
||||
|
||||
(define (with-timeout timeout thunk)
|
||||
(define result #f)
|
||||
(let ([r (sync/timeout timeout
|
||||
(thread (lambda () (set! result (thunk)))))])
|
||||
(if r result (error-value "timeout"))))
|
||||
|
||||
(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 (if (exn? e) (exn-message e) e)))])
|
||||
expr)]))
|
||||
;; Get server information, carefully
|
||||
(define version-info
|
||||
(parameterize ([current-input-port
|
||||
(try (get-pure-port (string->url version-url))
|
||||
"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)
|
||||
(symbol? (car x))
|
||||
(= 2 (length 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
|
||||
[(equal? 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) (regexp-match #rx"[.]" current))
|
||||
`(newer ,recent)]
|
||||
;; new version out, we have an outdated stable, there is also an alpha
|
||||
[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.
|
||||
(provide check-version)
|
||||
(define (check-version)
|
||||
(with-timeout timeout check-version/timeout))
|
||||
|
||||
)
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(module checksigs mzscheme
|
||||
(require (lib "unitsig.ss"))
|
||||
(provide empty^ extra-params^ defs^)
|
||||
(define-signature empty^
|
||||
())
|
||||
(define-signature extra-params^
|
||||
(check-frame
|
||||
sync?))
|
||||
(define-signature defs^
|
||||
(run-thunk
|
||||
show-ok
|
||||
show-error-ok
|
||||
make-wait-dialog
|
||||
show-wait-dialog
|
||||
hide-wait-dialog)))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(module go-check mzscheme
|
||||
(require (lib "unitsig.ss") "checksigs.ss" "runcheck.ss")
|
||||
(provide go-check)
|
||||
(define (go-check frame the-sync defs@)
|
||||
(let ([extra-params@ (unit/sig extra-params^ (import)
|
||||
(define check-frame frame)
|
||||
(define sync? the-sync))])
|
||||
(invoke-unit/sig
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link
|
||||
[CFRAME : extra-params^ (extra-params@)]
|
||||
[DEFS : defs^ (defs@)]
|
||||
[RUNCHECK : empty^ (runcheck@ (CFRAME) (DEFS))])
|
||||
(export))))))
|
||||
|
|
@ -1,119 +0,0 @@
|
|||
(module gui-defs mzscheme
|
||||
(require (lib "unitsig.ss") (lib "class.ss") (lib "mred.ss" "mred")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
"checksigs.ss")
|
||||
(provide gui-defs@)
|
||||
(define gui-defs@
|
||||
(unit/sig defs^ (import)
|
||||
|
||||
(define (run-thunk th)
|
||||
(parameterize ([current-eventspace (make-eventspace)])
|
||||
(queue-callback th)))
|
||||
|
||||
;; string (list string (listof string)) (union (listof string) #f) -> void
|
||||
(define (show-ok title captions details ok-thunk)
|
||||
(letrec ([frame
|
||||
(instantiate frame% ()
|
||||
[label title]
|
||||
[min-width 50]
|
||||
[alignment '(left center)]
|
||||
[stretchable-height #f]
|
||||
[stretchable-width #f]
|
||||
[style '(no-resize-border)])]
|
||||
[main-panel (instantiate vertical-panel% ()
|
||||
[parent frame]
|
||||
[stretchable-width #f]
|
||||
[stretchable-height #f]
|
||||
[alignment '(center center)])]
|
||||
[panel-sep 4]
|
||||
[msg-width 50]
|
||||
[make-make-panel
|
||||
(lambda (c%)
|
||||
(lambda ()
|
||||
(instantiate c% ()
|
||||
[parent main-panel]
|
||||
[vert-margin panel-sep]
|
||||
[alignment '(center center)])))]
|
||||
[make-hpanel (make-make-panel horizontal-panel%)]
|
||||
[make-vpanel (make-make-panel vertical-panel%)]
|
||||
[row-panel (make-vpanel)]
|
||||
[make-msg
|
||||
(lambda (msg panel)
|
||||
(instantiate message% ()
|
||||
[min-width msg-width] [label msg] [parent panel]))]
|
||||
[status-msgs (map (lambda (msg) (make-msg msg row-panel))
|
||||
captions)]
|
||||
[details-panel #f]
|
||||
[showing-details #f]
|
||||
[details-text "Details "]
|
||||
[show-details-button-text (string-append details-text ">>")]
|
||||
[hide-details-button-text (string-append details-text "<<")]
|
||||
[hide-details
|
||||
(lambda ()
|
||||
(set! showing-details #f)
|
||||
(send main-panel delete-child details-panel)
|
||||
(send details-button set-label show-details-button-text)
|
||||
(set! details-panel #f))]
|
||||
[show-details
|
||||
(lambda ()
|
||||
(set! showing-details #t)
|
||||
(send details-button set-label hide-details-button-text)
|
||||
(set! details-button-callback hide-details)
|
||||
(unless details-panel
|
||||
(set! details-panel
|
||||
(instantiate vertical-panel% ()
|
||||
(parent main-panel)
|
||||
(style '(border))
|
||||
(border 2)
|
||||
(vert-margin panel-sep)
|
||||
(alignment '(left center))))
|
||||
(for-each (lambda (d) (make-msg d details-panel))
|
||||
details)))]
|
||||
[details-button-callback
|
||||
(lambda (e bv)
|
||||
(if showing-details (hide-details) (show-details)))]
|
||||
[buttons-panel (make-hpanel)]
|
||||
[ok-button (instantiate button% ()
|
||||
[label "OK"] [min-width 20] [parent buttons-panel]
|
||||
[callback (lambda (b ev)
|
||||
(send frame show #f)
|
||||
(ok-thunk))])]
|
||||
[spacer
|
||||
(and details
|
||||
(instantiate message% ()
|
||||
[min-width 20] [label ""] [parent buttons-panel]))]
|
||||
[details-button
|
||||
(and details
|
||||
(not (null? details))
|
||||
(instantiate button% ()
|
||||
[label show-details-button-text]
|
||||
[min-width 20]
|
||||
[parent buttons-panel]
|
||||
[callback details-button-callback]))])
|
||||
(send frame center)
|
||||
(send frame show #t)))
|
||||
|
||||
(define (show-error-ok title caption)
|
||||
(show-ok title
|
||||
(list (format (string-constant vc-error-format) caption))
|
||||
#f
|
||||
void))
|
||||
|
||||
(define (make-wait-dialog parent title caption close-fun)
|
||||
(let ([dialog (instantiate dialog% ()
|
||||
[label title] [parent parent] [width 100] [height 50]
|
||||
[stretchable-width #t] [stretchable-height #t])])
|
||||
(instantiate message% () [label caption] [parent dialog])
|
||||
(instantiate button% ()
|
||||
[label (string-constant cancel)]
|
||||
[parent dialog]
|
||||
[callback (lambda (button ce) (close-fun) (send dialog show #f))])
|
||||
dialog))
|
||||
|
||||
(define (show-wait-dialog dialog)
|
||||
(send dialog center)
|
||||
(thread (lambda () (send dialog show #t)))
|
||||
(send dialog focus))
|
||||
|
||||
(define (hide-wait-dialog dialog)
|
||||
(send dialog show #f)))))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "Version private"))
|
||||
|
|
@ -1,224 +0,0 @@
|
|||
(module runcheck mzscheme
|
||||
(require (lib "unitsig.ss") (lib "list.ss") (lib "url.ss" "net")
|
||||
(lib "getinfo.ss" "setup")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
"checksigs.ss" (lib "patchlevel.ss" "version"))
|
||||
(provide runcheck@)
|
||||
(define runcheck@
|
||||
(unit/sig empty^ (import extra-params^ defs^)
|
||||
|
||||
(define download-url-string "http://download.plt-scheme.org/")
|
||||
|
||||
(define sync-sem (make-semaphore 0))
|
||||
|
||||
(define ok-thunk
|
||||
(if sync? (lambda () (semaphore-post sync-sem)) void))
|
||||
|
||||
(define current-format (string-constant vc-current-format))
|
||||
|
||||
(define (make-url-string vcs)
|
||||
(string-append
|
||||
(apply string-append
|
||||
"http://download.plt-scheme.org/cgi-bin/check-version?"
|
||||
(map (lambda (cv)
|
||||
(string-append
|
||||
"package=" (car cv) "*" (cadr cv) "*" (caddr cv) "&"))
|
||||
vcs))
|
||||
"binary-version="
|
||||
(if (> patchlevel 0)
|
||||
(format "~ap~a" (version) patchlevel)
|
||||
(version))))
|
||||
|
||||
(define timeout-value 60)
|
||||
|
||||
(define the-port #f)
|
||||
|
||||
(define (get-collect-version-info collect)
|
||||
(let ([info-proc (get-info (list collect))])
|
||||
(if (not info-proc)
|
||||
(list 'no-info-file 'no-info-file)
|
||||
(list (info-proc 'release-version
|
||||
(lambda _ 'no-release-info))
|
||||
(info-proc 'release-iteration
|
||||
(lambda _ 'no-iteration-info))))))
|
||||
|
||||
(define (cvi-triples)
|
||||
;; find all collections
|
||||
(let ([collects-dirs (current-library-collection-paths)])
|
||||
(let outer-loop ([collects-dirs collects-dirs])
|
||||
(if (null? collects-dirs)
|
||||
'()
|
||||
(let* ([curr-collects-dir (car collects-dirs)]
|
||||
[dirs (filter
|
||||
(lambda (d)
|
||||
(directory-exists?
|
||||
(build-path curr-collects-dir d)))
|
||||
(if (directory-exists? curr-collects-dir)
|
||||
(directory-list curr-collects-dir)
|
||||
'()))])
|
||||
(let inner-loop ([dirs dirs])
|
||||
(if (null? dirs)
|
||||
(outer-loop (cdr collects-dirs))
|
||||
(let* ([curr-dir (car dirs)]
|
||||
[dir-version-and-iteration
|
||||
(get-collect-version-info curr-dir)])
|
||||
(if (andmap string? dir-version-and-iteration) ; not a symbol indicating an error
|
||||
(cons (cons curr-dir dir-version-and-iteration)
|
||||
(inner-loop (cdr dirs)))
|
||||
(inner-loop (cdr dirs)))))))))))
|
||||
|
||||
(define (go)
|
||||
(let* ([wait-dialog #f]
|
||||
[dialog-sem (make-semaphore 0)]
|
||||
[got-cancel? #f]
|
||||
[timer-proc
|
||||
(lambda ()
|
||||
(let loop ([n 0])
|
||||
(if (> n timeout-value)
|
||||
(begin
|
||||
(when wait-dialog (hide-wait-dialog wait-dialog))
|
||||
;; will force exception on pending read
|
||||
(if the-port
|
||||
(close-input-port the-port)
|
||||
(set! got-cancel? #t))
|
||||
(run-thunk
|
||||
(lambda ()
|
||||
(show-ok (string-constant vc-network-timeout)
|
||||
(list (string-constant vc-cannot-connect))
|
||||
#f
|
||||
ok-thunk))))
|
||||
(begin (sleep 1) (loop (add1 n))))))]
|
||||
[timeout-thread (thread timer-proc)])
|
||||
|
||||
(run-thunk
|
||||
(lambda ()
|
||||
(set! wait-dialog
|
||||
(make-wait-dialog
|
||||
#f
|
||||
(string-constant vc-please-wait)
|
||||
(string-constant vc-connecting-version-server)
|
||||
(lambda ()
|
||||
(set! got-cancel? #t)
|
||||
(with-handlers ([void void]) ; thread might already be dead
|
||||
(kill-thread timeout-thread)
|
||||
(when the-port
|
||||
(close-input-port the-port))))))
|
||||
(show-wait-dialog wait-dialog)
|
||||
(semaphore-post dialog-sem)))
|
||||
|
||||
(semaphore-wait dialog-sem)
|
||||
|
||||
(set! the-port
|
||||
(with-handlers ([void
|
||||
(lambda _
|
||||
(kill-thread timeout-thread)
|
||||
(hide-wait-dialog wait-dialog)
|
||||
(unless got-cancel?
|
||||
(run-thunk
|
||||
(lambda ()
|
||||
(show-error-ok
|
||||
(string-constant vc-network-failure)
|
||||
(string-constant vc-cannot-connect)))))
|
||||
(raise 'network-error))])
|
||||
(get-pure-port
|
||||
(string->url (make-url-string (cvi-triples))))))
|
||||
|
||||
(when got-cancel? ; force exn in read, below
|
||||
(close-input-port the-port))
|
||||
|
||||
(let ([responses
|
||||
(let loop ()
|
||||
(let ([r (read the-port)])
|
||||
(if (eof-object? r)
|
||||
(begin (kill-thread timeout-thread)
|
||||
(hide-wait-dialog wait-dialog)
|
||||
'())
|
||||
(cons r (loop)))))]
|
||||
[needs-update #f])
|
||||
|
||||
(close-input-port the-port)
|
||||
|
||||
;; responses are a list of lists of symbol/string pairs:
|
||||
;; (((package name)
|
||||
;; (installed-version v)
|
||||
;; (installed-iteration v)
|
||||
;; (latest-version v)
|
||||
;; (latest-iteration v)
|
||||
;; (verdict s))
|
||||
;; ... )
|
||||
|
||||
;; first handle binary info, which is always first in responses
|
||||
|
||||
(let-values ([(_ binary-version binary-iteration
|
||||
latest-binary-version latest-binary-iteration
|
||||
binary-verdict)
|
||||
(apply values (map cadr (car responses)))])
|
||||
|
||||
(if (eq? binary-verdict 'update)
|
||||
|
||||
;; inform user of new binary
|
||||
|
||||
(show-ok
|
||||
(string-constant vc-update-dialog-title)
|
||||
(list
|
||||
(string-constant vc-old-binaries)
|
||||
(format
|
||||
(string-constant vc-binary-information-format)
|
||||
binary-version binary-iteration)
|
||||
(format
|
||||
(string-constant vc-latest-binary-information-format)
|
||||
latest-binary-version latest-binary-iteration)
|
||||
(string-append (string-constant vc-updates-available) " " download-url-string))
|
||||
#f
|
||||
ok-thunk)
|
||||
|
||||
;; else offer info for installed packages
|
||||
|
||||
(let* ([details
|
||||
(map
|
||||
(lambda (r)
|
||||
(let*-values
|
||||
([(data) (map cadr r)]
|
||||
[(package installed-version installed-iteration
|
||||
latest-version latest-iteration verdict)
|
||||
(apply values data)])
|
||||
(cond
|
||||
[(eq? verdict 'up-to-date)
|
||||
(format current-format
|
||||
package installed-version installed-iteration)]
|
||||
[(eq? verdict 'update)
|
||||
(set! needs-update #t)
|
||||
(format (string-constant vc-update-format)
|
||||
package
|
||||
installed-version installed-iteration
|
||||
latest-version latest-iteration)]
|
||||
[else ""])))
|
||||
(cdr responses))])
|
||||
|
||||
(show-ok
|
||||
(string-constant vc-update-dialog-title)
|
||||
(list (if needs-update
|
||||
(string-constant vc-need-update-string)
|
||||
(string-constant vc-no-update-string))
|
||||
(format current-format
|
||||
(string-constant vc-binary-name)
|
||||
binary-version binary-iteration))
|
||||
(if needs-update
|
||||
(append details
|
||||
(list
|
||||
""
|
||||
(string-constant vc-updates-available)
|
||||
download-url-string))
|
||||
details)
|
||||
ok-thunk)))))))
|
||||
|
||||
;; exceptions are used to report errors elsewhere
|
||||
;; just ignore here
|
||||
|
||||
(run-thunk
|
||||
(lambda ()
|
||||
(with-handlers ([void (lambda _
|
||||
(when sync? (semaphore-post sync-sem)))])
|
||||
(go))))
|
||||
|
||||
(when sync? (semaphore-wait sync-sem)))))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
(module text-defs mzscheme
|
||||
(require (lib "unitsig.ss") "checksigs.ss")
|
||||
|
||||
(provide text-defs@)
|
||||
|
||||
(define text-defs@
|
||||
(unit/sig defs^ (import)
|
||||
|
||||
(define (run-thunk th) (th))
|
||||
|
||||
;; string (list string (listof string)) (union (listof string) #f) -> void
|
||||
(define (show-ok title captions details ok-thunk) ; ok-thunk for gui, ignore here
|
||||
(printf "~a\n" (car captions))
|
||||
(for-each (lambda (c) (printf " ~a\n" c)) (cdr captions))
|
||||
(when (and details (not (null? details)))
|
||||
(printf "Details:\n")
|
||||
(for-each (lambda (d) (printf " ~a\n" d)) details)))
|
||||
|
||||
(define (show-error-ok title caption)
|
||||
(show-ok title (list (format "Error: ~a" caption)) #f void))
|
||||
|
||||
(define (make-wait-dialog parent title caption close-fun)
|
||||
(list title caption))
|
||||
|
||||
(define (show-wait-dialog dialog)
|
||||
;; dialog is the pair returned by make-wait-dialog
|
||||
(printf "~a\n" (cadr dialog)))
|
||||
|
||||
(define (hide-wait-dialog dialog)
|
||||
(void)))))
|
||||
Loading…
Reference in New Issue
Block a user