From c7db5817011ed854acc04d5d6d5eb79e367b2c46 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 13 Feb 2006 22:42:57 +0000 Subject: [PATCH] Added the updater, with instructions on how to turn it on. svn: r2219 --- collects/handin-client/client-gui.ss | 52 +++++++++++------- collects/handin-client/handin-multi.ss | 53 ++++++++++-------- collects/handin-client/info.ss | 22 +++++--- collects/handin-client/updater.ss | 76 ++++++++++++++++++++++++++ collects/handin-server/doc.txt | 27 +++++++++ 5 files changed, 180 insertions(+), 50 deletions(-) create mode 100644 collects/handin-client/updater.ss diff --git a/collects/handin-client/client-gui.ss b/collects/handin-client/client-gui.ss index 2b02ca7185..f0d1164b38 100644 --- a/collects/handin-client/client-gui.ss +++ b/collects/handin-client/client-gui.ss @@ -33,17 +33,23 @@ (define this-collection (#%info-lookup 'collection)) (define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f))) (define web-address (#%info-lookup 'web-address (lambda () #f))) + (define in-this-collection + (let ([path (collection-path this-collection)]) + (lambda (file) (build-path path file)))) (define handin-dialog-name (string-append handin-name " Handin")) (define button-label/h (string-append handin-name " Handin")) (define button-label/r (string-append handin-name " Retrieve")) (define manage-dialog-name (string-append handin-name " Handin Account")) + (define updater? + (#%info-lookup 'enable-auto-update (lambda () #f))) (define multifile? (#%info-lookup 'enable-multifile-handin (lambda () #f))) (define preference-key - (string->symbol (format "submit:username:~a" this-collection))) + (string->symbol + (format "~a:submit:username" (string-downcase this-collection)))) (preferences:set-default preference-key "" string?) (define (remembered-user) @@ -52,9 +58,7 @@ (preferences:set preference-key user)) (define (connect) - (handin-connect - server port-no - (build-path (collection-path this-collection) "server-cert.pem"))) + (handin-connect server port-no (in-this-collection "server-cert.pem"))) (provide handin-frame%) (define handin-frame% @@ -608,9 +612,7 @@ (send bm2 set-loaded-mask mbm2)) bm2)) - (define handin-icon - (scale-by-half - (build-path (collection-path this-collection) "icon.png"))) + (define handin-icon (scale-by-half (in-this-collection "icon.png"))) (define (editors->string editors) (let* ([base (make-object editor-stream-out-bytes-base%)] @@ -643,7 +645,10 @@ (import drscheme:tool^) (define phase1 void) - (define phase2 void) + (define phase2 + (if updater? + (dynamic-require (in-this-collection "updater.ss") 'bg-update) + void)) (define tool-button-label (bitmap-label-maker button-label/h handin-icon)) @@ -655,20 +660,29 @@ (super-instantiate ()) (define/override (file-menu:between-open-and-revert file-menu) + ;; super adds a separator, add this and another sep after that + (super file-menu:between-open-and-revert file-menu) (new menu-item% - (label (format "Manage ~a Handin Account..." handin-name)) - (parent file-menu) - (callback (lambda (m e) (manage-handin-account this)))) + [label (format "Manage ~a Handin Account..." handin-name)] + [parent file-menu] + [callback (lambda (m e) (manage-handin-account this))]) (when multifile? (new menu-item% - (label (format "Submit multiple ~a Files..." handin-name)) - (parent file-menu) - (callback (lambda (m e) - ((dynamic-require - (build-path (collection-path this-collection) - "handin-multi.ss") - 'multifile-handin)))))) - (super file-menu:between-open-and-revert file-menu)) + [label (format "Submit multiple ~a Files..." handin-name)] + [parent file-menu] + [callback (lambda (m e) + ((dynamic-require + (in-this-collection "handin-multi.ss") + 'multifile-handin)))])) + (when updater? + (new menu-item% + [label (format "Update ~a plugin..." handin-name)] + [parent file-menu] + [callback + (lambda (m e) + ((dynamic-require (in-this-collection "updater.ss") 'update) + #f #t))])) ; no parent + (new separator-menu-item% [parent file-menu])) (define/override (help-menu:after-about menu) (when web-menu-name diff --git a/collects/handin-client/handin-multi.ss b/collects/handin-client/handin-multi.ss index ec1e7d1530..8e0612ff73 100644 --- a/collects/handin-client/handin-multi.ss +++ b/collects/handin-client/handin-multi.ss @@ -2,24 +2,28 @@ (require (lib "class.ss") (lib "list.ss") (lib "string.ss") (lib "port.ss") (lib "unitsig.ss") (lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "external.ss" "browser") - "info.ss" "client-gui.ss" (only "updater.ss" update)) + "info.ss" "client-gui.ss") - (define handin-name (#%info-lookup 'name)) - (define this-collection (#%info-lookup 'collection)) - (define web-address (#%info-lookup 'web-address)) - (define selection-mode (#%info-lookup 'selection-mode)) + (define handin-name (#%info-lookup 'name)) + (define this-collection (#%info-lookup 'collection)) + (define web-address (#%info-lookup 'web-address)) + (define selection-mode (#%info-lookup 'selection-mode)) (define selection-defaults (let ([sd (#%info-lookup 'selection-default)]) (if (string? sd) (list sd) sd))) (define (make-key sfx) - (string->symbol (format "~a:~a" (string-downcase handin-name) sfx))) - (define last-dir-key (make-key 'handin-last-dir)) + (string->symbol (format "~a:~a" (string-downcase this-collection) sfx))) + (define last-dir-key (make-key 'multifile:last-dir)) (preferences:set-default last-dir-key "" string?) - (define last-auto-key (make-key 'handin-last-auto)) + (define last-auto-key (make-key 'multifile:last-auto)) (preferences:set-default last-auto-key (car selection-defaults) string?) - (define geometry-key (make-key 'handin-geometry)) + (define geometry-key (make-key 'multifile:geometry)) (preferences:set-default geometry-key #f void) + (define update + (and (#%info-lookup 'enable-auto-update (lambda () #f)) + (dynamic-require (in-this-collection "updater.ss") 'bg-update))) + ;; ========================================================================== (define magic #"<<>>") (define (pack-files files) @@ -52,19 +56,20 @@ (reverse! files) (loop (cons f files)))))] [overwrite-all? #f]) (define (write? file) - (define (del) (delete-file file) #t) - (cond - [(not (file-exists? file)) #t] - [overwrite-all? (del)] - [else (case (message-box/custom - "Retrieve" - (format "~s already exists, overwrite?" file) - "&Yes" "&No" "Yes to &All" parent - '(default=2 caution) 4) - [(1) (del)] - [(2) #f] - [(3) (set! overwrite-all? #t) (del)] - [(4) (error* "Aborting...")])])) + (define (del) + ;; check if exists: users might rename files during questions + (when (file-exists? file) (delete-file file))) + (cond [(not (file-exists? file)) #t] + [overwrite-all? (del) #t] + [else (case (message-box/custom + "Retrieve" + (format "~s already exists, overwrite?" file) + "&Yes" "&No" "Yes to &All" parent + '(default=2 caution) 4) + [(1) (del) #t] + [(2) #f] + [(3) (set! overwrite-all? #t) (del) #t] + [(4) (error* "Aborting...")])])) (unless (and (list? files) (andmap (lambda (x) (and (list? x) (= 2 (length x)) @@ -115,7 +120,7 @@ (button "&Submit" (lambda _ (do-submit))) (button "&Retrieve" (lambda _ (do-retrieve))) (button "A&ccount" (lambda _ (manage-handin-account this))) - (button "&Update" (lambda _ (update this #t))) + (when update (button "&Update" (lambda _ (update this #t)))) (button "C&lose" (lambda _ (close)))) ;; ---------------------------------------------------------------------- @@ -268,7 +273,7 @@ (send this accept-drop-files #t) (send choose-dir-button focus) (send this show #t) - (update this))) + (when update (update this)))) (provide multifile-handin) (define (multifile-handin) (new multifile-dialog%)) diff --git a/collects/handin-client/info.ss b/collects/handin-client/info.ss index 6282d9bc1d..680a673d29 100644 --- a/collects/handin-client/info.ss +++ b/collects/handin-client/info.ss @@ -14,13 +14,21 @@ ;(define web-menu-name "Course Homepage") ;(define web-address "http://www.university.edu/course/") - (define tool-icons (list (list "icon.png" collection))) - (define tools '(("client-gui.ss"))) - (define tool-names (list name)) + (define tools `(("client-gui.ss"))) + (define tool-names `(,name)) + (define tool-icons `(("icon.png" ,collection))) + (define requires '(("mred") ("openssl"))) + ;; Auto-updater section (see handin-server/doc.txt for details) + ;(define enable-auto-update #t) ; enable auto-update? + ;(define version-filename "handin-version") + ;(define package-filename "handin.plt") + ;; Multi-file submission section (see handin-server/doc.txt for details) - (define enable-multifile-handin #f) ; enable multi-file? - (define selection-mode 'extended) ; mode for file choose, usually 'extended - (define selection-default ; suffixes to auto-choose (a string or string-list) - '("*.scm;*.ss" "*.scm;*.ss;*.txt"))) + ;(define enable-multifile-handin #t) ; enable multi-file? + ;(define selection-mode 'extended) ; mode for file choose, usually 'extended + ;(define selection-default ; suffixes to auto-choose (string or string-list) + ; '("*.scm;*.ss" "*.scm;*.ss;*.txt")) + + ) diff --git a/collects/handin-client/updater.ss b/collects/handin-client/updater.ss new file mode 100644 index 0000000000..7034b684a8 --- /dev/null +++ b/collects/handin-client/updater.ss @@ -0,0 +1,76 @@ +(module updater mzscheme + (require "info.ss" (lib "url.ss" "net") (lib "plt-installer.ss" "setup") + (lib "etc.ss") (lib "file.ss") (lib "port.ss") + (lib "mred.ss" "mred") (lib "framework.ss" "framework")) + (define name (#%info-lookup 'name)) + (define collection (#%info-lookup 'collection)) + (define web-address (#%info-lookup 'web-address)) + (define version-filename (#%info-lookup 'version-filename)) + (define package-filename (#%info-lookup 'package-filename)) + (define dialog-title (string-append name " Updater")) + (define (file->inport filename) + (get-pure-port + (string->url + (string-append (regexp-replace #rx"/?$" web-address "/") filename)))) + (define update-key + (string->symbol (format "~a:update-check" (string-downcase collection)))) + (preferences:set-default update-key #t boolean?) + + (define (update!) + (let* ([in (file->inport package-filename)] + [outf (make-temporary-file "tmp~a.plt")] + [out (open-output-file outf 'binary 'truncate)]) + (dynamic-wind void + (lambda () (copy-port in out)) + (lambda () (close-input-port in) (close-output-port out))) + (run-installer outf (lambda () (delete-file outf))))) + (define (maybe-update parent new-version) + (define response + (message-box/custom + dialog-title + (string-append + "A new version of the "name" plugin is available: " + (let ([v (format "~a" new-version)]) + (if (= 12 (string-length v)) + (apply format "~a~a~a~a/~a~a/~a~a ~a~a:~a~a" (string->list v)) + v))) + "&Update now" "Remind Me &Later" + ;; may be disabled, but explicitly invoked through menu item + (if (preferences:get update-key) + "&Stop Checking" "Update and &Always Check") + parent '(default=1 caution) 2)) + (case response + [(1) (update!)] + [(2) 'ok] ; do nothing + [(3) (preferences:set update-key (not (preferences:get update-key))) + (when (preferences:get update-key) (update!))] + [else (error 'update "internal error in ~a plugin updater" name)])) + (provide update) + (define (update parent . show-ok?) + (let* ([web-version + (with-handlers ([void (lambda _ 0)]) + (let ([in (file->inport version-filename)]) + (dynamic-wind void + (lambda () (read in)) + (lambda () (close-input-port in)))))] + ;; if the file was not there, we might have read some junk + [web-version (if (integer? web-version) web-version 0)] + [current-version + (with-input-from-file + (build-path (this-expression-source-directory) "version") + read)]) + (cond [(> web-version current-version) (maybe-update parent web-version)] + [(and (pair? show-ok?) (car show-ok?)) + (message-box dialog-title "Your plugin is up-to-date" parent)]))) + + (define (wait-for-top-level-windows) + ;; wait until the definitions are instantiated, return top-level window + (let ([ws (get-top-level-windows)]) + (if (null? ws) (begin (sleep 1) (wait-for-top-level-windows)) (car ws)))) + (provide bg-update) + (define (bg-update) + (thread (lambda () + (when (preferences:get update-key) + (update (wait-for-top-level-windows)))))) + + ) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index bb0ee4b939..9216be707e 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -979,3 +979,30 @@ application: in the account management dialog, the "Un/Install" tab has a button that will ask for a directory where it will create an executable for the multi-file submission utility -- the resulting executable can be used outside of DrScheme. + +*** Auto-updater + +The handin-client has code that can be used for automatic updating of +clients. This can be useful for courses where you distribute some +additional functionality (collections, teachpacks, language-levels +etc), and this functionality can change (or expected to change, for +example, distributing per-homework teachpacks). + +To enable this, uncomment the relevant part of the "info.ss" file in +the client code, it has the following three keys: `enable-auto-update' +that turns this facility on, `version-filename' and `package-filename' +which are the expected file names of the version file and the .plt +file relative to the course web address (the value of the +`web-address' key). Also, include in your client collection a +"version" file that contains a single number that is its version -- a +big integer that holds the time of this collection in a YYYYMMDDHHMM +format. + +When students install the client, every time DrScheme starts, it will +automatically check the version from the web page (as specified by the +`web-address' and `version-filename' keys), and if that contains a +bigger number, it will offer the students to download and install the +new version. So, every time you want to distribute a new version, you +build a new .plt file that contains a new version file, then copy +these version and .plt files to your web page, and students will be +notified automatically.