suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added the updater, with instructions on how to turn it on.

Browse Source 
svn: r2219
This commit is contained in:
Eli Barzilay 2006-02-13 22:42:57 +00:00
parent c5ce7c5a04
commit c7db581701
5 changed files with 180 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/handin-client/client-gui.ss
View File

@ -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

53
collects/handin-client/handin-multi.ss
View File

@ -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 #"<<<MULTI-SUBMISSION-FILE>>>")
(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%))

22
collects/handin-client/info.ss
View File

@ -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"))
)

76
collects/handin-client/updater.ss Normal file
View File

@ -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))))))
)

27
collects/handin-server/doc.txt
View File

@ -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.