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

Misc improvements, the main two:

Browse Source 
* No need to define `collection' in info.ss
* Catches connection error when using the management dialog (so it is
  still possible to uninstall)

svn: r5292
This commit is contained in:
Eli Barzilay 2007-01-10 09:19:31 +00:00
parent c56394a0fc
commit 95a1888c8f
6 changed files with 407 additions and 375 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,15 +1,9 @@
(module client-gui mzscheme (module client-gui mzscheme
(require (lib "mred.ss" "mred") (require (lib "class.ss") (lib "unit.ss") (lib "file.ss")
(lib "class.ss") (lib "sendurl.ss" "net") (lib "mred.ss" "mred")
(lib "unit.ss")
(lib "tool.ss" "drscheme")
(lib "etc.ss")
(lib "file.ss")
(lib "framework.ss" "framework")
(lib "sendurl.ss" "net")
(lib "bitmap-label.ss" "mrlib") (lib "bitmap-label.ss" "mrlib")
"client.ss" (lib "tool.ss" "drscheme") (lib "framework.ss" "framework")
"info.ss") "info.ss" "client.ss" "this-collection.ss")
(provide tool@) (provide tool@)
@ -28,12 +22,8 @@
(values #f #f))) (values #f #f)))
(define handin-name (#%info-lookup 'name)) (define handin-name (#%info-lookup 'name))
(define this-collection (#%info-lookup 'collection))
(define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f))) (define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f)))
(define web-address (#%info-lookup 'web-address (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 handin-dialog-name (string-append handin-name " Handin"))
(define button-label/h (string-append handin-name " Handin")) (define button-label/h (string-append handin-name " Handin"))
@ -45,9 +35,7 @@
(define multifile? (define multifile?
(#%info-lookup 'enable-multifile-handin (lambda () #f))) (#%info-lookup 'enable-multifile-handin (lambda () #f)))
(define preference-key (define preference-key (make-my-key 'submit:username))
(string->symbol
(format "~a:submit:username" (string-downcase this-collection))))
(preferences:set-default preference-key "" string?) (preferences:set-default preference-key "" string?)
(define (remembered-user) (define (remembered-user)
@ -55,8 +43,7 @@
(define (remember-user user) (define (remember-user user)
(preferences:set preference-key user)) (preferences:set preference-key user))
(define (connect) (define (connect) (handin-connect server port-no))
(handin-connect server port-no (in-this-collection "server-cert.pem")))
(provide handin-frame%) (provide handin-frame%)
(define handin-frame% (define handin-frame%
@ -282,38 +269,37 @@
(center) (center)
(show #t))) (show #t)))
(provide manage-handin-account) (define manage-handin-dialog%
(define (manage-handin-account parent) (class dialog% (init [parent #f] [user-fields #f])
(new
(class dialog%
(inherit show is-shown? center) (inherit show is-shown? center)
(super-new [label manage-dialog-name] (super-new [label manage-dialog-name]
[alignment '(left center)] [alignment '(left center)]
[parent parent]) [parent parent])
(define USER-FIELDS
(let ([ef #f])
(lambda ()
(unless ef (set! ef (retrieve-user-fields (connect))))
ef)))
(define status (define status
(new message% (new message%
[label (format "Manage ~a handin account at ~a." [label (if user-fields
handin-name server)] (format "Manage ~a handin account at ~a."
handin-name server)
"No connection to server!")]
[parent this] [parent this]
[stretchable-width #t])) [stretchable-width #t]))
(define tabs (define tabs
(new tab-panel% (let* ([names (list (if multifile? "Un/Install" "Uninstall"))]
[parent this] [names (if user-fields
[choices `("New User" "Change Info" `("New User" "Change Info" ,@names) names)]
,(if multifile? "Un/Install" "Uninstall"))] [callback (lambda _
[callback
(lambda (tp e)
(send single active-child (send single active-child
(list-ref (list new-user-box old-user-box un/install-box) (if user-fields
(send tabs get-selection))))])) (case (send tabs get-selection)
[(0) new-user-box]
[(1) old-user-box]
[(2) un/install-box]
[else (error "internal error")])
un/install-box)))])
(new tab-panel% [parent this] [choices names] [callback callback])))
(define single (new panel:single% [parent tabs])) (define single (new panel:single% [parent tabs]))
@ -350,8 +336,7 @@
(if an-extra-non-empty? "Change Info" "Set Password"))) (if an-extra-non-empty? "Change Info" "Set Password")))
(define old-user-box (new vertical-panel% (define old-user-box (new vertical-panel%
[parent single] [parent single] [alignment '(center center)]))
[alignment '(center center)]))
(define old-username (mk-txt "Username:" old-user-box activate-change)) (define old-username (mk-txt "Username:" old-user-box activate-change))
(send old-username set-value (remembered-user)) (send old-username set-value (remembered-user))
@ -360,7 +345,7 @@
(define change-user-fields (define change-user-fields
(map (lambda (f) (map (lambda (f)
(mk-txt (string-append f ":") old-user-box activate-change)) (mk-txt (string-append f ":") old-user-box activate-change))
(USER-FIELDS))) (or user-fields '())))
(define new-passwd (define new-passwd
(mk-passwd "New Password:" old-user-box activate-change)) (mk-passwd "New Password:" old-user-box activate-change))
(define new-passwd2 (define new-passwd2
@ -373,10 +358,12 @@
[alignment '(center center)])]) [alignment '(center center)])])
(make-object vertical-pane% p) (make-object vertical-pane% p)
(values (values
(begin0 (new button% [label "Get Current Info"] [parent p] (begin0 (new button%
[label "Get Current Info"] [parent p]
[callback (lambda (b e) (do-retrieve old-username))]) [callback (lambda (b e) (do-retrieve old-username))])
(make-object vertical-pane% p)) (make-object vertical-pane% p))
(begin0 (new button% [label "Set Password"] [parent p] [style '(border)] (begin0 (new button%
[label "Set Password"] [parent p] [style '(border)]
[callback (lambda (b e) [callback (lambda (b e)
(do-change/add #f old-username))]) (do-change/add #f old-username))])
(make-object vertical-pane% p))))) (make-object vertical-pane% p)))))
@ -387,19 +374,17 @@
add-user-fields) add-user-fields)
(same-value add-passwd add-passwd2)))) (same-value add-passwd add-passwd2))))
(define new-user-box (new vertical-panel% (define new-user-box (new vertical-panel%
[parent single] [parent single] [alignment '(center center)]))
[alignment '(center center)]))
(define new-username (mk-txt "Username:" new-user-box activate-new)) (define new-username (mk-txt "Username:" new-user-box activate-new))
(send new-username set-value (remembered-user)) (send new-username set-value (remembered-user))
(define add-user-fields (define add-user-fields
(map (lambda (f) (map (lambda (f)
(mk-txt (string-append f ":") new-user-box activate-new)) (mk-txt (string-append f ":") new-user-box activate-new))
(USER-FIELDS))) (or user-fields '())))
(define add-passwd (mk-passwd "Password:" new-user-box activate-new)) (define add-passwd (mk-passwd "Password:" new-user-box activate-new))
(define add-passwd2 (mk-passwd "Password again:" new-user-box activate-new)) (define add-passwd2 (mk-passwd "Password again:" new-user-box activate-new))
(define new-button (new button% (define new-button (new button%
[label "Add User"] [label "Add User"] [parent new-user-box]
[parent new-user-box]
[callback (lambda (b e) [callback (lambda (b e)
(do-change/add #t new-username))] (do-change/add #t new-username))]
[style '(border)])) [style '(border)]))
@ -412,11 +397,9 @@
[parent un/install-box] [parent un/install-box]
[callback [callback
(lambda (b e) (lambda (b e)
(let ([dir (collection-path this-collection)]) (with-handlers ([void (lambda (exn)
(with-handlers ([void
(lambda (exn)
(report-error "Uninstall failed." exn))]) (report-error "Uninstall failed." exn))])
(delete-directory/files dir) (delete-directory/files (in-this-collection))
(set! uninstalled? #t) (set! uninstalled? #t)
(send uninstall-button enable #f) (send uninstall-button enable #f)
(message-box "Uninstall" (message-box "Uninstall"
@ -425,7 +408,7 @@
"The Handin button and associated menu items will" "The Handin button and associated menu items will"
" not appear after you restart DrScheme.") " not appear after you restart DrScheme.")
this) this)
(send this show #f))))])) (send this show #f)))]))
(send uninstall-button enable (not uninstalled?)) (send uninstall-button enable (not uninstalled?))
(define install-standalone-button (define install-standalone-button
@ -458,7 +441,8 @@
exe "it will be overwritten") exe "it will be overwritten")
this '(ok-cancel caution)))) this '(ok-cancel caution))))
((launcher 'make-mred-launcher) ((launcher 'make-mred-launcher)
(list "-mvLe-" "handin-multi.ss" this-collection (list "-mvLe-" "handin-multi.ss"
this-collection-name
"(multifile-handin)") "(multifile-handin)")
(build-path dir exe)) (build-path dir exe))
(message-box "Standalone Executable" (message-box "Standalone Executable"
@ -476,9 +460,7 @@
"Server Error" "Server Error"
(if (exn? exn) (if (exn? exn)
(let ([s (exn-message exn)]) (let ([s (exn-message exn)])
(if (string? s) (if (string? s) s (format "~e" s))))
s
(format "~e" s))))
this) this)
(set! comm-cust (make-custodian)))))) (set! comm-cust (make-custodian))))))
@ -487,20 +469,18 @@
(inner (void) on-close) (inner (void) on-close)
(custodian-shutdown-all comm-cust)) (custodian-shutdown-all comm-cust))
(define button-panel (new horizontal-pane% (define button-panel
[parent this] (new horizontal-pane% [parent this] [stretchable-height #f]))
[stretchable-height #f]))
(make-object vertical-pane% button-panel) ; spacer (make-object vertical-pane% button-panel) ; spacer
(define cancel (new button% (define cancel
[label "Cancel"] (new button%
[parent button-panel] [label "Cancel"] [parent button-panel]
[callback (lambda (b e) [callback (lambda (b e)
(custodian-shutdown-all comm-cust) (custodian-shutdown-all comm-cust)
(show #f))])) (show #f))]))
;; Too-long fields can't damage the server, but they might ;; Too-long fields can't damage the server, but they might result in
;; result in confusing errors due to safety cut-offs on ;; confusing errors due to safety cut-offs on the server side.
;; the server side.
(define (check-length field size name k) (define (check-length field size name k)
(when ((string-length (send field get-value)) . > . size) (when ((string-length (send field get-value)) . > . size)
(message-box "Error" (message-box "Error"
@ -524,16 +504,16 @@
(k (void)))) (k (void))))
(for-each (lambda (t f) (check-length t 100 f k)) (for-each (lambda (t f) (check-length t 100 f k))
(if new? add-user-fields change-user-fields) (if new? add-user-fields change-user-fields)
(USER-FIELDS)) (or user-fields '()))
(send tabs enable #f) (send tabs enable #f)
(parameterize ([current-custodian comm-cust]) (parameterize ([current-custodian comm-cust])
(thread (thread
(lambda () (lambda ()
(with-handlers (with-handlers ([void (lambda (exn)
([void (lambda (exn)
(send tabs enable #t) (send tabs enable #t)
(report-error (report-error
(format "~a failed." (if new? "Creation" "Update")) (format "~a failed."
(if new? "Creation" "Update"))
exn))]) exn))])
(remember-user (send username get-value)) (remember-user (send username get-value))
(send status set-label "Making secure connection...") (send status set-label "Making secure connection...")
@ -545,8 +525,7 @@
(send status set-label (send status set-label
(if new? "Creating user..." "Updating server...")) (if new? "Creating user..." "Updating server..."))
(if new? (if new?
(run submit-addition username add-passwd (run submit-addition username add-passwd add-user-fields)
add-user-fields)
(run submit-info-change username old-passwd new-passwd (run submit-info-change username old-passwd new-passwd
change-user-fields))) change-user-fields)))
(send status set-label "Success.") (send status set-label "Success.")
@ -570,8 +549,7 @@
(if (list? x) (map loop x) (send x get-value))))) (if (list? x) (map loop x) (send x get-value)))))
(send status set-label "Retrieving information...") (send status set-label "Retrieving information...")
(let ([vals (run retrieve-user-info username old-passwd)]) (let ([vals (run retrieve-user-info username old-passwd)])
(send status set-label (send status set-label "Success, you can now edit fields.")
"Success, you can now edit fields.")
(send tabs enable #t) (send tabs enable #t)
(for-each (lambda (f val) (send f set-value val)) (for-each (lambda (f val) (send f set-value val))
change-user-fields vals) change-user-fields vals)
@ -581,13 +559,23 @@
(send old-user-box show #f) (send old-user-box show #f)
(send un/install-box show #f) (send un/install-box show #f)
(let ([new? (equal? "" (remembered-user))]) (let ([new? (equal? "" (remembered-user))])
(send single active-child (if new? old-user-box new-user-box)) (if user-fields
(send single active-child (if new? new-user-box old-user-box)) (send* single (active-child (if new? old-user-box new-user-box))
(send tabs set-selection (if new? 0 1))) (active-child (if new? new-user-box old-user-box)))
(send single active-child un/install-box))
(send tabs set-selection (if user-fields (if new? 0 1) 0)))
(activate-new) (activate-new)
(activate-change) (activate-change)
(center) (center)
(show #t)))) (show #t)))
(provide manage-handin-account)
(define (manage-handin-account parent)
(new manage-handin-dialog%
[parent parent]
[user-fields (cond [(with-handlers ([void (lambda (_) #f)]) (connect))
=> retrieve-user-fields]
[else #f])]))
(define (scale-by-half file) (define (scale-by-half file)
(let* ([bm (make-object bitmap% file 'unknown/mask)] (let* ([bm (make-object bitmap% file 'unknown/mask)]
@ -639,7 +627,7 @@
(define phase1 void) (define phase1 void)
(define phase2 (define phase2
(if updater? (if updater?
(dynamic-require `(lib "updater.ss" ,this-collection) 'bg-update) (dynamic-require `(lib "updater.ss" ,this-collection-name) 'bg-update)
void)) void))
(define tool-button-label (bitmap-label-maker button-label/h handin-icon)) (define tool-button-label (bitmap-label-maker button-label/h handin-icon))
@ -664,7 +652,7 @@
[parent file-menu] [parent file-menu]
[callback (lambda (m e) [callback (lambda (m e)
((dynamic-require ((dynamic-require
`(lib "handin-multi.ss" ,this-collection) `(lib "handin-multi.ss" ,this-collection-name)
'multifile-handin)))])) 'multifile-handin)))]))
(when updater? (when updater?
(new menu-item% (new menu-item%
@ -672,7 +660,7 @@
[parent file-menu] [parent file-menu]
[callback [callback
(lambda (m e) (lambda (m e)
((dynamic-require `(lib "updater.ss" ,this-collection) ((dynamic-require `(lib "updater.ss" ,this-collection-name)
'update) 'update)
#f #t))])) ; no parent #f #t))])) ; no parent
(new separator-menu-item% [parent file-menu])) (new separator-menu-item% [parent file-menu]))

25
collects/handin-client/client.ss
View File

@ -1,5 +1,5 @@
(module client mzscheme (module client mzscheme
(require (lib "mzssl.ss" "openssl")) (require (lib "mzssl.ss" "openssl") "this-collection.ss")
(provide handin-connect (provide handin-connect
handin-disconnect handin-disconnect
@ -25,11 +25,26 @@
(let ([v (if (pair? reader) ((car reader)) (read r))]) (let ([v (if (pair? reader) ((car reader)) (read r))])
(unless (eq? v 'ok) (error 'handin-connect "~a error: ~a" who v)))) (unless (eq? v 'ok) (error 'handin-connect "~a error: ~a" who v))))
(define (handin-connect server port pem) ;; ssl connection, makes an easier error message if no connection
(let ([ctx (ssl-make-client-context)]) (define (connect-to server port)
(define pem (in-this-collection "server-cert.pem"))
(define ctx (ssl-make-client-context))
(ssl-set-verify! ctx #t) (ssl-set-verify! ctx #t)
(ssl-load-verify-root-certificates! ctx pem) (ssl-load-verify-root-certificates! ctx pem)
(let-values ([(r w) (ssl-connect server port ctx)]) (with-handlers
([exn:fail:network?
(lambda (e)
(let* ([msg
"handin-connect: could not connect to the server (~a:~a)"]
[msg (format msg server port)]
#; ; un-comment to get the full message too
[msg (string-append msg " (" (exn-message e) ")")]
[msg (string->immutable-string msg)])
(raise (make-exn:fail:network msg (exn-continuation-marks e)))))])
(ssl-connect server port ctx)))
(define (handin-connect server port)
(let-values ([(r w) (connect-to server port)])
;; Sanity check: server sends "handin", first: ;; Sanity check: server sends "handin", first:
(let ([s (read-bytes 6 r)]) (let ([s (read-bytes 6 r)])
(unless (equal? #"handin" s) (unless (equal? #"handin" s)
@ -41,7 +56,7 @@
(unless (eq? s 'ver1) (unless (eq? s 'ver1)
(error 'handin-connect "bad protocol from server: ~e" s))) (error 'handin-connect "bad protocol from server: ~e" s)))
;; Return connection: ;; Return connection:
(make-handin r w)))) (make-handin r w)))
(define (handin-disconnect h) (define (handin-disconnect h)
(write+flush (handin-w h) 'bye) (write+flush (handin-w h) 'bye)

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

@ -1,29 +1,26 @@
(module handin-multi mzscheme (module handin-multi mzscheme
(require (lib "class.ss") (lib "list.ss") (lib "string.ss") (lib "port.ss") (require (lib "class.ss") (lib "list.ss") (lib "string.ss") (lib "port.ss")
(lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "mred.ss" "mred") (lib "framework.ss" "framework")
(lib "external.ss" "browser") "info.ss" "client-gui.ss") (lib "external.ss" "browser")
"info.ss" "client-gui.ss" "this-collection.ss")
(define handin-name (#%info-lookup 'name)) (define handin-name (#%info-lookup 'name))
(define this-collection (#%info-lookup 'collection))
(define web-address (#%info-lookup 'web-address (define web-address (#%info-lookup 'web-address
(lambda () "http://www.plt-scheme.org"))) (lambda () "http://www.plt-scheme.org")))
(define selection-mode (#%info-lookup 'selection-mode (define selection-mode (#%info-lookup 'selection-mode (lambda () 'extended)))
(lambda () 'extended)))
(define selection-defaults (define selection-defaults
(let ([sd (#%info-lookup 'selection-default (lambda () '("*.scm" "*.ss")))]) (let ([sd (#%info-lookup 'selection-default (lambda () '("*.scm" "*.ss")))])
(if (string? sd) (list sd) sd))) (if (string? sd) (list sd) sd)))
(define (make-key sfx) (define last-dir-key (make-my-key 'multifile: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?) (preferences:set-default last-dir-key "" string?)
(define last-auto-key (make-key 'multifile:last-auto)) (define last-auto-key (make-my-key 'multifile:last-auto))
(preferences:set-default last-auto-key (car selection-defaults) string?) (preferences:set-default last-auto-key (car selection-defaults) string?)
(define geometry-key (make-key 'multifile:geometry)) (define geometry-key (make-my-key 'multifile:geometry))
(preferences:set-default geometry-key #f void) (preferences:set-default geometry-key #f void)
(define update (define update
(and (#%info-lookup 'enable-auto-update (lambda () #f)) (and (#%info-lookup 'enable-auto-update (lambda () #f))
(dynamic-require `(lib "updater.ss" ,this-collection) 'update))) (dynamic-require `(lib "updater.ss" ,this-collection-name) 'update)))
;; ========================================================================== ;; ==========================================================================
(define magic #"<<<MULTI-SUBMISSION-FILE>>>") (define magic #"<<<MULTI-SUBMISSION-FILE>>>")
@ -105,14 +102,13 @@
(preferences:set geometry-key (preferences:set geometry-key
(list (send this get-width) (send this get-height) (list (send this get-width) (send this get-height)
(send this get-x) (send this get-y))) (send this get-x) (send this get-y)))
;; (preferences:save)
(send this show #f)) (send this show #f))
(define/augment (on-close) (close)) (define/augment (on-close) (close))
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
(new button% [parent buttons-pane] (new button% [parent buttons-pane]
[label (make-object bitmap% [label (make-object bitmap% (in-this-collection "icon.png"))]
(build-path (collection-path this-collection)
"icon.png"))]
[callback (lambda _ (send-url web-address))]) [callback (lambda _ (send-url web-address))])
(new pane% [parent buttons-pane]) (new pane% [parent buttons-pane])
(let ([button (lambda (label callback) (let ([button (lambda (label callback)

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

@ -4,7 +4,6 @@
;; Instead of uncommenting the definition of server:port, you ;; Instead of uncommenting the definition of server:port, you
;; can set the PLT_HANDIN_SERVER_PORT environment variable. ;; can set the PLT_HANDIN_SERVER_PORT environment variable.
(define name "Course") (define name "Course")
(define collection "handin-client")
;(define server:port "localhost:7979") ;(define server:port "localhost:7979")
;; The following are optional. Uncomment and fill in ;; The following are optional. Uncomment and fill in
@ -14,9 +13,9 @@
;(define web-menu-name "Course Homepage") ;(define web-menu-name "Course Homepage")
;(define web-address "http://www.university.edu/course/") ;(define web-address "http://www.university.edu/course/")
(define tools `(("client-gui.ss"))) (define tools `("client-gui.ss"))
(define tool-names `(,name)) (define tool-names `(,name))
(define tool-icons `(("icon.png" ,collection))) (define tool-icons `("icon.png"))
(define requires '(("mred") ("openssl"))) (define requires '(("mred") ("openssl")))

37
collects/handin-client/this-collection.ss Normal file
View File

@ -0,0 +1,37 @@
(module this-collection mzscheme
(define-syntax (this-name-stx stx)
(let* ([p (syntax-source stx)]
[dir (and (path? p) (let-values ([(b _1 _2) (split-path p)]) b))]
[name (and (path? dir)
;; path->string + bytes->path is a hack to get a proper
;; string because there is no path-element->string
(path->string
(bytes->path
(path-element->bytes
(let-values ([(_1 p _2) (split-path dir)]) p)))))])
;; check that we are installed as a top-level collection (this is needed
;; because there are some code bits (that depend on bindings from this
;; file) that expect this to be true)
(with-handlers
([void (lambda (e)
(raise
(make-exn:fail
"*** Error: this collection must be a top-level collection"
(exn-continuation-marks e))))])
(collection-path name))
(datum->syntax-object stx name stx)))
(provide this-collection-name)
(define this-collection-name this-name-stx)
(define this-collection-path (collection-path this-collection-name))
(provide in-this-collection)
(define (in-this-collection . paths)
(apply build-path this-collection-path paths))
(provide make-my-key)
(define (make-my-key sym)
(string->symbol (format "handin:~a:~a" this-collection-name sym)))
)

15
collects/handin-client/updater.ss
View File

@ -1,9 +1,9 @@
(module updater mzscheme (module updater mzscheme
(require "info.ss" (lib "url.ss" "net") (lib "plt-installer.ss" "setup") (require (lib "file.ss") (lib "port.ss") (lib "url.ss" "net")
(lib "etc.ss") (lib "file.ss") (lib "port.ss") (lib "plt-installer.ss" "setup") (lib "mred.ss" "mred")
(lib "mred.ss" "mred") (lib "framework.ss" "framework")) (lib "framework.ss" "framework")
"info.ss" "this-collection.ss")
(define name (#%info-lookup 'name)) (define name (#%info-lookup 'name))
(define collection (#%info-lookup 'collection))
(define web-address (#%info-lookup 'web-address)) (define web-address (#%info-lookup 'web-address))
(define version-filename (#%info-lookup 'version-filename)) (define version-filename (#%info-lookup 'version-filename))
(define package-filename (#%info-lookup 'package-filename)) (define package-filename (#%info-lookup 'package-filename))
@ -12,8 +12,7 @@
(get-pure-port (get-pure-port
(string->url (string->url
(string-append (regexp-replace #rx"/?$" web-address "/") filename)))) (string-append (regexp-replace #rx"/?$" web-address "/") filename))))
(define update-key (define update-key (make-my-key 'update-check))
(string->symbol (format "~a:update-check" (string-downcase collection))))
(preferences:set-default update-key #t boolean?) (preferences:set-default update-key #t boolean?)
(define (update!) (define (update!)
@ -56,9 +55,7 @@
;; if the file was not there, we might have read some junk ;; if the file was not there, we might have read some junk
[web-version (if (integer? web-version) web-version 0)] [web-version (if (integer? web-version) web-version 0)]
[current-version [current-version
(with-input-from-file (with-input-from-file (in-this-collection "version") read)])
(build-path (this-expression-source-directory) "version")
read)])
(cond [(> web-version current-version) (maybe-update parent web-version)] (cond [(> web-version current-version) (maybe-update parent web-version)]
[(and (pair? show-ok?) (car show-ok?)) [(and (pair? show-ok?) (car show-ok?))
(message-box dialog-title "Your plugin is up-to-date" parent)]))) (message-box dialog-title "Your plugin is up-to-date" parent)])))