225 lines
9.1 KiB
Scheme
225 lines
9.1 KiB
Scheme
(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)))))
|