more v4-updates
svn: r11679
This commit is contained in:
Eli Barzilay
parent
41a4f4b2ae
commit
5675f4574c
|
|
@ -1,171 +1,170 @@
|
|||
(module client mzscheme
|
||||
(require openssl/mzssl "this-collection.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(provide handin-connect
|
||||
handin-disconnect
|
||||
retrieve-user-fields
|
||||
retrieve-active-assignments
|
||||
submit-assignment
|
||||
retrieve-assignment
|
||||
submit-addition
|
||||
submit-info-change
|
||||
retrieve-user-info)
|
||||
(require openssl/mzssl "this-collection.ss")
|
||||
|
||||
(define-struct handin (r w))
|
||||
(provide handin-connect
|
||||
handin-disconnect
|
||||
retrieve-user-fields
|
||||
retrieve-active-assignments
|
||||
submit-assignment
|
||||
retrieve-assignment
|
||||
submit-addition
|
||||
submit-info-change
|
||||
retrieve-user-info)
|
||||
|
||||
;; errors to the user: no need for a "foo: " prefix
|
||||
(define (error* fmt . args)
|
||||
(error (apply format fmt args)))
|
||||
(define-struct handin (r w))
|
||||
|
||||
(define (write+flush port . xs)
|
||||
(for-each (lambda (x) (write x port) (newline port)) xs)
|
||||
(flush-output port))
|
||||
;; errors to the user: no need for a "foo: " prefix
|
||||
(define (error* fmt . args)
|
||||
(error (apply format fmt args)))
|
||||
|
||||
(define (close-handin-ports h)
|
||||
(close-input-port (handin-r h))
|
||||
(close-output-port (handin-w h)))
|
||||
(define (write+flush port . xs)
|
||||
(for ([x xs]) (write x port) (newline port))
|
||||
(flush-output port))
|
||||
|
||||
(define (wait-for-ok r who . reader)
|
||||
(let ([v (if (pair? reader) ((car reader)) (read r))])
|
||||
(unless (eq? v 'ok) (error* "~a error: ~a" who v))))
|
||||
(define (close-handin-ports h)
|
||||
(close-input-port (handin-r h))
|
||||
(close-output-port (handin-w h)))
|
||||
|
||||
;; ssl connection, makes a readable error message if no connection
|
||||
(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-load-verify-root-certificates! ctx pem)
|
||||
(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) ")")])
|
||||
(raise (make-exn:fail:network msg (exn-continuation-marks e)))))])
|
||||
(ssl-connect server port ctx)))
|
||||
(define (wait-for-ok r who . reader)
|
||||
(let ([v (if (pair? reader) ((car reader)) (read r))])
|
||||
(unless (eq? v 'ok) (error* "~a error: ~a" who v))))
|
||||
|
||||
(define (handin-connect server port)
|
||||
(let-values ([(r w) (connect-to server port)])
|
||||
;; Sanity check: server sends "handin", first:
|
||||
(let ([s (read-bytes 6 r)])
|
||||
(unless (equal? #"handin" s)
|
||||
(error 'handin-connect "bad handshake from server: ~e" s)))
|
||||
;; Tell server protocol = 'ver1:
|
||||
(write+flush w 'ver1)
|
||||
;; One more sanity check: server recognizes protocol:
|
||||
(let ([s (read r)])
|
||||
(unless (eq? s 'ver1)
|
||||
(error 'handin-connect "bad protocol from server: ~e" s)))
|
||||
;; Return connection:
|
||||
(make-handin r w)))
|
||||
;; ssl connection, makes a readable error message if no connection
|
||||
(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-load-verify-root-certificates! ctx pem)
|
||||
(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) ")")])
|
||||
(raise (make-exn:fail:network msg (exn-continuation-marks e)))))])
|
||||
(ssl-connect server port ctx)))
|
||||
|
||||
(define (handin-disconnect h)
|
||||
(write+flush (handin-w h) 'bye)
|
||||
(close-handin-ports h))
|
||||
(define (handin-connect server port)
|
||||
(let-values ([(r w) (connect-to server port)])
|
||||
;; Sanity check: server sends "handin", first:
|
||||
(let ([s (read-bytes 6 r)])
|
||||
(unless (equal? #"handin" s)
|
||||
(error 'handin-connect "bad handshake from server: ~e" s)))
|
||||
;; Tell server protocol = 'ver1:
|
||||
(write+flush w 'ver1)
|
||||
;; One more sanity check: server recognizes protocol:
|
||||
(let ([s (read r)])
|
||||
(unless (eq? s 'ver1)
|
||||
(error 'handin-connect "bad protocol from server: ~e" s)))
|
||||
;; Return connection:
|
||||
(make-handin r w)))
|
||||
|
||||
(define (retrieve-user-fields h)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w 'get-user-fields 'bye)
|
||||
(define (handin-disconnect h)
|
||||
(write+flush (handin-w h) 'bye)
|
||||
(close-handin-ports h))
|
||||
|
||||
(define (retrieve-user-fields h)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w 'get-user-fields 'bye)
|
||||
(let ([v (read r)])
|
||||
(unless (and (list? v) (andmap string? v))
|
||||
(error* "failed to get user-fields list from server"))
|
||||
(wait-for-ok r "get-user-fields")
|
||||
(close-handin-ports h)
|
||||
v)))
|
||||
|
||||
(define (retrieve-active-assignments h)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w 'get-active-assignments)
|
||||
(let ([v (read r)])
|
||||
(unless (and (list? v) (andmap string? v))
|
||||
(error* "failed to get active-assignment list from server"))
|
||||
v)))
|
||||
|
||||
(define (submit-assignment h username passwd assignment content
|
||||
on-commit message message-final message-box)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(define (read/message)
|
||||
(let ([v (read r)])
|
||||
(unless (and (list? v) (andmap string? v))
|
||||
(error* "failed to get user-fields list from server"))
|
||||
(wait-for-ok r "get-user-fields")
|
||||
(case v
|
||||
[(message) (message (read r)) (read/message)]
|
||||
[(message-final) (message-final (read r)) (read/message)]
|
||||
[(message-box)
|
||||
(write+flush w (message-box (read r) (read r))) (read/message)]
|
||||
[else v])))
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'set 'assignment assignment
|
||||
'save-submission)
|
||||
(wait-for-ok r "login")
|
||||
(write+flush w (bytes-length content))
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'go) (error* "upload error: ~a" v)))
|
||||
(display "$" w)
|
||||
(display content w)
|
||||
(flush-output w)
|
||||
;; during processing, we're waiting for 'confirm, in the meanwhile, we
|
||||
;; can get a 'message or 'message-box to show -- after 'message we expect
|
||||
;; a string to show using the `messenge' argument, and after 'message-box
|
||||
;; we expect a string and a style-list to be used with `message-box' and
|
||||
;; the resulting value written back
|
||||
(let ([v (read/message)])
|
||||
(unless (eq? 'confirm v) (error* "submit error: ~a" v)))
|
||||
(on-commit)
|
||||
(write+flush w 'check)
|
||||
(wait-for-ok r "commit" read/message)
|
||||
(close-handin-ports h)))
|
||||
|
||||
(define (retrieve-assignment h username passwd assignment)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'set 'assignment assignment
|
||||
'get-submission)
|
||||
(let ([len (read r)])
|
||||
(unless (and (number? len) (integer? len) (positive? len))
|
||||
(error* "bad response from server: ~a" len))
|
||||
(let ([buf (begin (regexp-match #rx"[$]" r) (read-bytes len r))])
|
||||
(wait-for-ok r "get-submission")
|
||||
(close-handin-ports h)
|
||||
v)))
|
||||
buf))))
|
||||
|
||||
(define (retrieve-active-assignments h)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w 'get-active-assignments)
|
||||
(let ([v (read r)])
|
||||
(unless (and (list? v) (andmap string? v))
|
||||
(error* "failed to get active-assignment list from server"))
|
||||
v)))
|
||||
(define (submit-addition h username passwd user-fields)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'set 'user-fields user-fields
|
||||
'create-user)
|
||||
(wait-for-ok r "create-user")
|
||||
(close-handin-ports h)))
|
||||
|
||||
(define (submit-assignment h username passwd assignment content
|
||||
on-commit message message-final message-box)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(define (read/message)
|
||||
(let ([v (read r)])
|
||||
(case v
|
||||
[(message) (message (read r)) (read/message)]
|
||||
[(message-final) (message-final (read r)) (read/message)]
|
||||
[(message-box)
|
||||
(write+flush w (message-box (read r) (read r))) (read/message)]
|
||||
[else v])))
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'set 'assignment assignment
|
||||
'save-submission)
|
||||
(wait-for-ok r "login")
|
||||
(write+flush w (bytes-length content))
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'go) (error* "upload error: ~a" v)))
|
||||
(display "$" w)
|
||||
(display content w)
|
||||
(flush-output w)
|
||||
;; during processing, we're waiting for 'confirm, in the meanwhile, we
|
||||
;; can get a 'message or 'message-box to show -- after 'message we expect
|
||||
;; a string to show using the `messenge' argument, and after 'message-box
|
||||
;; we expect a string and a style-list to be used with `message-box' and
|
||||
;; the resulting value written back
|
||||
(let ([v (read/message)])
|
||||
(unless (eq? 'confirm v) (error* "submit error: ~a" v)))
|
||||
(on-commit)
|
||||
(write+flush w 'check)
|
||||
(wait-for-ok r "commit" read/message)
|
||||
(close-handin-ports h)))
|
||||
(define (submit-info-change h username old-passwd new-passwd user-fields)
|
||||
(let ([r (handin-r h)]
|
||||
[w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password old-passwd
|
||||
'set 'new-password new-passwd
|
||||
'set 'user-fields user-fields
|
||||
'change-user-info)
|
||||
(wait-for-ok r "change-user-info")
|
||||
(close-handin-ports h)))
|
||||
|
||||
(define (retrieve-assignment h username passwd assignment)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'set 'assignment assignment
|
||||
'get-submission)
|
||||
(let ([len (read r)])
|
||||
(unless (and (number? len) (integer? len) (positive? len))
|
||||
(error* "bad response from server: ~a" len))
|
||||
(let ([buf (begin (regexp-match #rx"[$]" r) (read-bytes len r))])
|
||||
(wait-for-ok r "get-submission")
|
||||
(close-handin-ports h)
|
||||
buf))))
|
||||
|
||||
(define (submit-addition h username passwd user-fields)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'set 'user-fields user-fields
|
||||
'create-user)
|
||||
(wait-for-ok r "create-user")
|
||||
(close-handin-ports h)))
|
||||
|
||||
(define (submit-info-change h username old-passwd new-passwd user-fields)
|
||||
(let ([r (handin-r h)]
|
||||
[w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password old-passwd
|
||||
'set 'new-password new-passwd
|
||||
'set 'user-fields user-fields
|
||||
'change-user-info)
|
||||
(wait-for-ok r "change-user-info")
|
||||
(close-handin-ports h)))
|
||||
|
||||
(define (retrieve-user-info h username passwd)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'get-user-info 'bye)
|
||||
(let ([v (read r)])
|
||||
(unless (and (list? v) (andmap string? v))
|
||||
(error* "failed to get user-info list from server"))
|
||||
(wait-for-ok r "get-user-info")
|
||||
(close-handin-ports h)
|
||||
v)))
|
||||
|
||||
)
|
||||
(define (retrieve-user-info h username passwd)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'get-user-info 'bye)
|
||||
(let ([v (read r)])
|
||||
(unless (and (list? v) (andmap string? v))
|
||||
(error* "failed to get user-info list from server"))
|
||||
(wait-for-ok r "get-user-info")
|
||||
(close-handin-ports h)
|
||||
v)))
|
||||
|
|
|
|||
|
|
@ -1,282 +1,276 @@
|
|||
(module handin-multi mzscheme
|
||||
(require mzlib/class mzlib/list mzlib/string mzlib/port
|
||||
mred framework
|
||||
browser/external
|
||||
"info.ss" "client-gui.ss" "this-collection.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(define handin-name (#%info-lookup 'name))
|
||||
(define web-address (#%info-lookup 'web-address
|
||||
(lambda () "http://www.plt-scheme.org")))
|
||||
(define selection-mode (#%info-lookup 'selection-mode (lambda () 'extended)))
|
||||
(define selection-defaults
|
||||
(let ([sd (#%info-lookup 'selection-default (lambda () '("*.scm" "*.ss")))])
|
||||
(if (string? sd) (list sd) sd)))
|
||||
(define last-dir-key (make-my-key 'multifile:last-dir))
|
||||
(preferences:set-default last-dir-key "" string?)
|
||||
(define last-auto-key (make-my-key 'multifile:last-auto))
|
||||
(preferences:set-default last-auto-key (car selection-defaults) string?)
|
||||
(define geometry-key (make-my-key 'multifile:geometry))
|
||||
(preferences:set-default geometry-key #f void)
|
||||
(require scheme/class scheme/port mred framework browser/external
|
||||
"info.ss" "client-gui.ss" "this-collection.ss")
|
||||
|
||||
(define update
|
||||
(and (#%info-lookup 'enable-auto-update (lambda () #f))
|
||||
(dynamic-require `(lib "updater.ss" ,this-collection-name) 'update)))
|
||||
(define handin-name (#%info-lookup 'name))
|
||||
(define web-address (#%info-lookup 'web-address
|
||||
(lambda () "http://www.plt-scheme.org")))
|
||||
(define selection-mode (#%info-lookup 'selection-mode (lambda () 'extended)))
|
||||
(define selection-defaults
|
||||
(let ([sd (#%info-lookup 'selection-default (lambda () '("*.scm" "*.ss")))])
|
||||
(if (string? sd) (list sd) sd)))
|
||||
(define last-dir-key (make-my-key 'multifile:last-dir))
|
||||
(preferences:set-default last-dir-key "" string?)
|
||||
(define last-auto-key (make-my-key 'multifile:last-auto))
|
||||
(preferences:set-default last-auto-key (car selection-defaults) string?)
|
||||
(define geometry-key (make-my-key 'multifile:geometry))
|
||||
(preferences:set-default geometry-key #f void)
|
||||
|
||||
;; ==========================================================================
|
||||
(define magic #"<<<MULTI-SUBMISSION-FILE>>>")
|
||||
(define (pack-files files)
|
||||
(let/ec return
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(printf "~a\n" magic)
|
||||
(for-each
|
||||
(lambda (file)
|
||||
(let ([size (and (file-exists? file) (file-size file))])
|
||||
(unless size (return #f))
|
||||
(let ([buf (with-input-from-file file
|
||||
(lambda () (read-bytes size)))])
|
||||
(unless (equal? size (bytes-length buf)) (return #f))
|
||||
(write (list file buf)) (newline))))
|
||||
files)
|
||||
(flush-output)
|
||||
(get-output-bytes (current-output-port)))))
|
||||
(define ((unpack-files parent) buf)
|
||||
(let/ec return
|
||||
(define (error* msg)
|
||||
(message-box "Retrieve Error" msg parent)
|
||||
(return #f))
|
||||
(parameterize ([current-input-port (open-input-bytes buf)])
|
||||
(unless (equal? magic (read-bytes (bytes-length magic)))
|
||||
(define update
|
||||
(and (#%info-lookup 'enable-auto-update (lambda () #f))
|
||||
(dynamic-require `(lib "updater.ss" ,this-collection-name) 'update)))
|
||||
|
||||
;; ==========================================================================
|
||||
(define magic #"<<<MULTI-SUBMISSION-FILE>>>")
|
||||
(define (pack-files files)
|
||||
(let/ec return
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(printf "~a\n" magic)
|
||||
(for ([file files])
|
||||
(let ([size (and (file-exists? file) (file-size file))])
|
||||
(unless size (return #f))
|
||||
(let ([buf (with-input-from-file file
|
||||
(lambda () (read-bytes size)))])
|
||||
(unless (equal? size (bytes-length buf)) (return #f))
|
||||
(write (list file buf)) (newline))))
|
||||
(flush-output)
|
||||
(get-output-bytes (current-output-port)))))
|
||||
(define ((unpack-files parent) buf)
|
||||
(let/ec return
|
||||
(define (error* msg)
|
||||
(message-box "Retrieve Error" msg parent)
|
||||
(return #f))
|
||||
(parameterize ([current-input-port (open-input-bytes buf)])
|
||||
(unless (equal? magic (read-bytes (bytes-length magic)))
|
||||
(error* "Error in retrieved content: bad format"))
|
||||
(let ([files
|
||||
(let loop ([files '()])
|
||||
(let ([f (with-handlers ([void void]) (read))])
|
||||
(if (eof-object? f)
|
||||
(reverse files) (loop (cons f files)))))]
|
||||
[overwrite-all? #f])
|
||||
(define (write? file)
|
||||
(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))
|
||||
(string? (car x)) (bytes? (cadr x))))
|
||||
files))
|
||||
(error* "Error in retrieved content: bad format"))
|
||||
(let ([files
|
||||
(let loop ([files '()])
|
||||
(let ([f (with-handlers ([void void]) (read))])
|
||||
(if (eof-object? f)
|
||||
(reverse files) (loop (cons f files)))))]
|
||||
[overwrite-all? #f])
|
||||
(define (write? file)
|
||||
(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))
|
||||
(string? (car x)) (bytes? (cadr x))))
|
||||
files))
|
||||
(error* "Error in retrieved content: bad format"))
|
||||
(for-each (lambda (file)
|
||||
(let ([file (car file)] [buf (cadr file)])
|
||||
(when (write? file)
|
||||
(with-output-to-file file
|
||||
(lambda () (display buf) (flush-output))))))
|
||||
files)
|
||||
(message-box "Retrieve" "Retrieval done" parent)))))
|
||||
(for ([file files])
|
||||
(let ([file (car file)] [buf (cadr file)])
|
||||
(when (write? file)
|
||||
(with-output-to-file file
|
||||
(lambda () (display buf) (flush-output))))))
|
||||
(message-box "Retrieve" "Retrieval done" parent)))))
|
||||
|
||||
;; ==========================================================================
|
||||
(define multifile-dialog%
|
||||
(class frame%
|
||||
;; ----------------------------------------------------------------------
|
||||
(let ([g (preferences:get geometry-key)])
|
||||
(super-new [label (format "~a Handin" handin-name)]
|
||||
[stretchable-width #t] [stretchable-height #t]
|
||||
[width (and g (car g))] [height (and g (cadr g))]
|
||||
[x (and g (caddr g))] [y (and g (cadddr g))]))
|
||||
(define main-pane (new horizontal-pane% [parent this]))
|
||||
(define buttons-pane
|
||||
(new vertical-pane% [parent main-pane] [stretchable-width #f]))
|
||||
(define files-pane
|
||||
(new vertical-pane% [parent main-pane]))
|
||||
;; ==========================================================================
|
||||
(define multifile-dialog%
|
||||
(class frame%
|
||||
;; ----------------------------------------------------------------------
|
||||
(let ([g (preferences:get geometry-key)])
|
||||
(super-new [label (format "~a Handin" handin-name)]
|
||||
[stretchable-width #t] [stretchable-height #t]
|
||||
[width (and g (car g))] [height (and g (cadr g))]
|
||||
[x (and g (caddr g))] [y (and g (cadddr g))]))
|
||||
(define main-pane (new horizontal-pane% [parent this]))
|
||||
(define buttons-pane
|
||||
(new vertical-pane% [parent main-pane] [stretchable-width #f]))
|
||||
(define files-pane
|
||||
(new vertical-pane% [parent main-pane]))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(define (close)
|
||||
(preferences:set geometry-key
|
||||
(list (send this get-width) (send this get-height)
|
||||
(send this get-x) (send this get-y)))
|
||||
;; (preferences:save)
|
||||
(send this show #f))
|
||||
(define/augment (on-close) (close))
|
||||
;; ----------------------------------------------------------------------
|
||||
(define (close)
|
||||
(preferences:set geometry-key
|
||||
(list (send this get-width) (send this get-height)
|
||||
(send this get-x) (send this get-y)))
|
||||
;; (preferences:save)
|
||||
(send this show #f))
|
||||
(define/augment (on-close) (close))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(new button% [parent buttons-pane]
|
||||
[label (make-object bitmap% (in-this-collection "icon.png"))]
|
||||
[callback (lambda _ (send-url web-address))])
|
||||
(new pane% [parent buttons-pane])
|
||||
(let ([button (lambda (label callback)
|
||||
(new button% [label label] [parent buttons-pane]
|
||||
[stretchable-width #t] [callback callback]))])
|
||||
(button "&Submit" (lambda _ (do-submit)))
|
||||
(button "&Retrieve" (lambda _ (do-retrieve)))
|
||||
(button "A&ccount" (lambda _ (new manage-handin-dialog% [parent this])))
|
||||
(when update (button "&Update" (lambda _ (update this #t))))
|
||||
(button "C&lose" (lambda _ (close))))
|
||||
;; ----------------------------------------------------------------------
|
||||
(new button% [parent buttons-pane]
|
||||
[label (make-object bitmap% (in-this-collection "icon.png"))]
|
||||
[callback (lambda _ (send-url web-address))])
|
||||
(new pane% [parent buttons-pane])
|
||||
(let ([button (lambda (label callback)
|
||||
(new button% [label label] [parent buttons-pane]
|
||||
[stretchable-width #t] [callback callback]))])
|
||||
(button "&Submit" (lambda _ (do-submit)))
|
||||
(button "&Retrieve" (lambda _ (do-retrieve)))
|
||||
(button "A&ccount" (lambda _ (new manage-handin-dialog% [parent this])))
|
||||
(when update (button "&Update" (lambda _ (update this #t))))
|
||||
(button "C&lose" (lambda _ (close))))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(define files-list
|
||||
(new list-box% [label "&Files:"] [parent files-pane]
|
||||
[style `(,selection-mode vertical-label)] [enabled #f]
|
||||
[choices '("Drag something here," "or click below")]
|
||||
[min-height 100] [stretchable-width #t] [stretchable-height #t]))
|
||||
(define auto-select
|
||||
(new combo-field% [label "&Auto:"] [parent files-pane]
|
||||
[init-value (preferences:get last-auto-key)]
|
||||
[choices selection-defaults]
|
||||
[callback (lambda (t e)
|
||||
(when (eq? (send e get-event-type) 'text-field-enter)
|
||||
(preferences:set last-auto-key (send t get-value))
|
||||
(do-selections '() '())))]))
|
||||
(define directory-pane
|
||||
(new horizontal-pane% [parent files-pane]
|
||||
[stretchable-width #t] [stretchable-height #f]))
|
||||
(define choose-dir-button
|
||||
(new button% [label "&Directory:"] [parent directory-pane]
|
||||
[callback (lambda _ (choose-dir))]))
|
||||
(define current-working-directory
|
||||
(new text-field% [label #f] [parent directory-pane] [init-value ""]
|
||||
[callback (lambda (t e)
|
||||
(when (eq? (send e get-event-type) 'text-field-enter)
|
||||
(set-dir (send t get-value))
|
||||
(send t focus)))]))
|
||||
;; ----------------------------------------------------------------------
|
||||
(define files-list
|
||||
(new list-box% [label "&Files:"] [parent files-pane]
|
||||
[style `(,selection-mode vertical-label)] [enabled #f]
|
||||
[choices '("Drag something here," "or click below")]
|
||||
[min-height 100] [stretchable-width #t] [stretchable-height #t]))
|
||||
(define auto-select
|
||||
(new combo-field% [label "&Auto:"] [parent files-pane]
|
||||
[init-value (preferences:get last-auto-key)]
|
||||
[choices selection-defaults]
|
||||
[callback (lambda (t e)
|
||||
(when (eq? (send e get-event-type) 'text-field-enter)
|
||||
(preferences:set last-auto-key (send t get-value))
|
||||
(do-selections '() '())))]))
|
||||
(define directory-pane
|
||||
(new horizontal-pane% [parent files-pane]
|
||||
[stretchable-width #t] [stretchable-height #f]))
|
||||
(define choose-dir-button
|
||||
(new button% [label "&Directory:"] [parent directory-pane]
|
||||
[callback (lambda _ (choose-dir))]))
|
||||
(define current-working-directory
|
||||
(new text-field% [label #f] [parent directory-pane] [init-value ""]
|
||||
[callback (lambda (t e)
|
||||
(when (eq? (send e get-event-type) 'text-field-enter)
|
||||
(set-dir (send t get-value))
|
||||
(send t focus)))]))
|
||||
(let ([ldir (preferences:get last-dir-key)])
|
||||
;; don't use init-value since it can get very long
|
||||
(send current-working-directory set-value ldir)
|
||||
(unless (equal? "" ldir) (current-directory ldir)))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(define dir-selected? #f)
|
||||
(define (->string x)
|
||||
(cond [(string? x) x]
|
||||
[(path? x) (path->string x)]
|
||||
[(bytes? x) (bytes->string/utf-8 x)]
|
||||
[(symbol? x) (symbol->string x)]
|
||||
[else (error '->string "bad input: ~e" x)]))
|
||||
(define (get-selected+unselected)
|
||||
(if (send files-list is-enabled?)
|
||||
(let ([selected (send files-list get-selections)])
|
||||
(let loop ([i (sub1 (send files-list get-number))] [s '()] [u '()])
|
||||
(if (<= 0 i)
|
||||
(let ([f (send files-list get-string i)])
|
||||
(if (memq i selected)
|
||||
(loop (sub1 i) (cons f s) u)
|
||||
(loop (sub1 i) s (cons f u))))
|
||||
(list (reverse s) (reverse u)))))
|
||||
'(() ())))
|
||||
(define (set-dir dir)
|
||||
(let* ([dir (and dir (->string dir))]
|
||||
[dir (and dir (not (equal? "" dir)) (directory-exists? dir)
|
||||
(->string (simplify-path (path->complete-path
|
||||
(build-path dir 'same)))))]
|
||||
[sel+unsel (if (equal? dir (->string (current-directory)))
|
||||
(get-selected+unselected) '(() ()))])
|
||||
(when dir
|
||||
(current-directory dir)
|
||||
(set! dir-selected? #t)
|
||||
(let ([t current-working-directory])
|
||||
(send t set-value dir)
|
||||
(send (send t get-editor) select-all))
|
||||
(preferences:set last-dir-key dir)
|
||||
(send files-list set
|
||||
(sort (map ->string (filter file-exists? (directory-list)))
|
||||
string<?))
|
||||
(if (< 0 (send files-list get-number))
|
||||
(begin (apply do-selections sel+unsel)
|
||||
(send files-list enable #t)
|
||||
(send files-list focus))
|
||||
(begin (send files-list append "no files")
|
||||
(send files-list enable #f))))))
|
||||
(define (choose-dir)
|
||||
(let ([ldir (preferences:get last-dir-key)])
|
||||
;; don't use init-value since it can get very long
|
||||
(send current-working-directory set-value ldir)
|
||||
(unless (equal? "" ldir) (current-directory ldir)))
|
||||
(set-dir
|
||||
(get-directory "Choose a directory with files to submit" this
|
||||
(and (not (equal? ldir "")) ldir)))))
|
||||
(define (refresh-dir)
|
||||
(when dir-selected? (set-dir (current-directory))))
|
||||
(define auto-glob+regexp '(#f #f))
|
||||
(define (globs->regexps glob)
|
||||
(if (equal? (car auto-glob+regexp) glob)
|
||||
(cdr auto-glob+regexp)
|
||||
(let* ([regexps
|
||||
(map (lambda (glob)
|
||||
(let* ([re (regexp-replace* #rx"[.]" glob "\\\\.")]
|
||||
[re (regexp-replace* #rx"[?]" re ".")]
|
||||
[re (regexp-replace* #rx"[*]" re ".*")]
|
||||
[re (string-append "^" re "$")]
|
||||
[re (with-handlers ([void (lambda _ #f)])
|
||||
(regexp re))])
|
||||
re))
|
||||
(regexp-split ";" glob))]
|
||||
[regexps (filter values regexps)]
|
||||
[regexps (if (pair? regexps)
|
||||
(lambda (file)
|
||||
(ormap (lambda (re) (regexp-match re file))
|
||||
regexps))
|
||||
(lambda (_) #f))])
|
||||
(set! auto-glob+regexp (cons glob regexps))
|
||||
regexps)))
|
||||
(define (do-selections selected unselected)
|
||||
(define glob (send auto-select get-value))
|
||||
(define regexps (globs->regexps glob))
|
||||
(let loop ([n (sub1 (send files-list get-number))])
|
||||
(when (<= 0 n)
|
||||
(let ([file (send files-list get-string n)])
|
||||
(send files-list select n
|
||||
(cond [(member file selected) #t]
|
||||
[(member file unselected) #f]
|
||||
[else (regexps file)]))
|
||||
(loop (sub1 n)))))
|
||||
(send (if (send files-list is-enabled?) files-list choose-dir-button)
|
||||
focus))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(define dir-selected? #f)
|
||||
(define (->string x)
|
||||
(cond [(string? x) x]
|
||||
[(path? x) (path->string x)]
|
||||
[(bytes? x) (bytes->string/utf-8 x)]
|
||||
[(symbol? x) (symbol->string x)]
|
||||
[else (error '->string "bad input: ~e" x)]))
|
||||
(define (get-selected+unselected)
|
||||
(if (send files-list is-enabled?)
|
||||
(let ([selected (send files-list get-selections)])
|
||||
(let loop ([i (sub1 (send files-list get-number))] [s '()] [u '()])
|
||||
(if (<= 0 i)
|
||||
(let ([f (send files-list get-string i)])
|
||||
(if (memq i selected)
|
||||
(loop (sub1 i) (cons f s) u)
|
||||
(loop (sub1 i) s (cons f u))))
|
||||
(list (reverse s) (reverse u)))))
|
||||
'(() ())))
|
||||
(define (set-dir dir)
|
||||
(let* ([dir (and dir (->string dir))]
|
||||
[dir (and dir (not (equal? "" dir)) (directory-exists? dir)
|
||||
(->string (simplify-path (path->complete-path
|
||||
(build-path dir 'same)))))]
|
||||
[sel+unsel (if (equal? dir (->string (current-directory)))
|
||||
(get-selected+unselected) '(() ()))])
|
||||
(when dir
|
||||
(current-directory dir)
|
||||
(set! dir-selected? #t)
|
||||
(let ([t current-working-directory])
|
||||
(send t set-value dir)
|
||||
(send (send t get-editor) select-all))
|
||||
(preferences:set last-dir-key dir)
|
||||
(send files-list set
|
||||
(sort (map ->string (filter file-exists? (directory-list)))
|
||||
string<?))
|
||||
(if (< 0 (send files-list get-number))
|
||||
(begin (apply do-selections sel+unsel)
|
||||
(send files-list enable #t)
|
||||
(send files-list focus))
|
||||
(begin (send files-list append "no files")
|
||||
(send files-list enable #f))))))
|
||||
(define (choose-dir)
|
||||
(let ([ldir (preferences:get last-dir-key)])
|
||||
(set-dir
|
||||
(get-directory "Choose a directory with files to submit" this
|
||||
(and (not (equal? ldir "")) ldir)))))
|
||||
(define (refresh-dir)
|
||||
(when dir-selected? (set-dir (current-directory))))
|
||||
(define auto-glob+regexp '(#f #f))
|
||||
(define (globs->regexps glob)
|
||||
(if (equal? (car auto-glob+regexp) glob)
|
||||
(cdr auto-glob+regexp)
|
||||
(let* ([regexps
|
||||
(map (lambda (glob)
|
||||
(let* ([re (regexp-replace* #rx"[.]" glob "\\\\.")]
|
||||
[re (regexp-replace* #rx"[?]" re ".")]
|
||||
[re (regexp-replace* #rx"[*]" re ".*")]
|
||||
[re (string-append "^" re "$")]
|
||||
[re (with-handlers ([void (lambda _ #f)])
|
||||
(regexp re))])
|
||||
re))
|
||||
(regexp-split ";" glob))]
|
||||
[regexps (filter values regexps)]
|
||||
[regexps (if (pair? regexps)
|
||||
(lambda (file)
|
||||
(ormap (lambda (re) (regexp-match re file))
|
||||
regexps))
|
||||
(lambda (_) #f))])
|
||||
(set! auto-glob+regexp (cons glob regexps))
|
||||
regexps)))
|
||||
(define (do-selections selected unselected)
|
||||
(define glob (send auto-select get-value))
|
||||
(define regexps (globs->regexps glob))
|
||||
(let loop ([n (sub1 (send files-list get-number))])
|
||||
(when (<= 0 n)
|
||||
(let ([file (send files-list get-string n)])
|
||||
(send files-list select n
|
||||
(cond [(member file selected) #t]
|
||||
[(member file unselected) #f]
|
||||
[else (regexps file)]))
|
||||
(loop (sub1 n)))))
|
||||
(send (if (send files-list is-enabled?) files-list choose-dir-button)
|
||||
focus))
|
||||
;; ----------------------------------------------------------------------
|
||||
(define/override (on-drop-file path)
|
||||
(cond [(directory-exists? path) (set-dir path)]
|
||||
[(file-exists? path)
|
||||
(let-values ([(dir name dir?) (split-path path)])
|
||||
(set-dir dir)
|
||||
(cond [(send files-list find-string (->string name))
|
||||
=> (lambda (i) (send files-list select i #t))]))]))
|
||||
(define/override (on-subwindow-char w e)
|
||||
(define (next) (super on-subwindow-char w e))
|
||||
(case (send e get-key-code)
|
||||
[(escape) (close)]
|
||||
[(f5) (refresh-dir)]
|
||||
;; [(#\space) (if (eq? w files-list)
|
||||
;; (printf ">>> ~s\n" (send files-list get-selection))
|
||||
;; (next))]
|
||||
[else (next)]))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(define/override (on-drop-file path)
|
||||
(cond [(directory-exists? path) (set-dir path)]
|
||||
[(file-exists? path)
|
||||
(let-values ([(dir name dir?) (split-path path)])
|
||||
(set-dir dir)
|
||||
(cond [(send files-list find-string (->string name))
|
||||
=> (lambda (i) (send files-list select i #t))]))]))
|
||||
(define/override (on-subwindow-char w e)
|
||||
(define (next) (super on-subwindow-char w e))
|
||||
(case (send e get-key-code)
|
||||
[(escape) (close)]
|
||||
[(f5) (refresh-dir)]
|
||||
;; [(#\space) (if (eq? w files-list)
|
||||
;; (printf ">>> ~s\n" (send files-list get-selection))
|
||||
;; (next))]
|
||||
[else (next)]))
|
||||
;; ----------------------------------------------------------------------
|
||||
(define (do-submit)
|
||||
(let ([files (car (get-selected+unselected))])
|
||||
(if (pair? files)
|
||||
(let ([content (pack-files files)])
|
||||
(if content
|
||||
(new handin-frame% [parent this] [on-retrieve #f]
|
||||
[content content])
|
||||
(message-box "Handin" "Error when packing files" this)))
|
||||
(message-box "Handin" "No files" this))))
|
||||
(define (do-retrieve)
|
||||
(if dir-selected?
|
||||
(new handin-frame% [parent this] [content #f]
|
||||
[on-retrieve (unpack-files this)])
|
||||
(message-box "Handin" "No directory selected" this)))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(define (do-submit)
|
||||
(let ([files (car (get-selected+unselected))])
|
||||
(if (pair? files)
|
||||
(let ([content (pack-files files)])
|
||||
(if content
|
||||
(new handin-frame% [parent this] [on-retrieve #f]
|
||||
[content content])
|
||||
(message-box "Handin" "Error when packing files" this)))
|
||||
(message-box "Handin" "No files" this))))
|
||||
(define (do-retrieve)
|
||||
(if dir-selected?
|
||||
(new handin-frame% [parent this] [content #f]
|
||||
[on-retrieve (unpack-files this)])
|
||||
(message-box "Handin" "No directory selected" this)))
|
||||
;; ----------------------------------------------------------------------
|
||||
(send this accept-drop-files #t)
|
||||
(send choose-dir-button focus)
|
||||
(send this show #t)
|
||||
(when update (update this))))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
(send this accept-drop-files #t)
|
||||
(send choose-dir-button focus)
|
||||
(send this show #t)
|
||||
(when update (update this))))
|
||||
|
||||
(provide multifile-handin)
|
||||
(define (multifile-handin) (new multifile-dialog%))
|
||||
|
||||
)
|
||||
(provide multifile-handin)
|
||||
(define (multifile-handin) (new multifile-dialog%))
|
||||
|
|
|
|||
|
|
@ -1,34 +1,34 @@
|
|||
(module this-collection mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(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)
|
||||
(bytes->string/locale
|
||||
(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)))
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(provide this-collection-name)
|
||||
(define this-collection-name this-name-stx)
|
||||
(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)
|
||||
(bytes->string/locale
|
||||
(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 stx 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 this-collection-name)
|
||||
(define this-collection-name this-name-stx)
|
||||
|
||||
(provide make-my-key)
|
||||
(define (make-my-key sym)
|
||||
(string->symbol (format "handin:~a:~a" this-collection-name sym)))
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -1,71 +1,72 @@
|
|||
(module updater mzscheme
|
||||
(require mzlib/file mzlib/port net/url setup/plt-installer mred framework
|
||||
"info.ss" "this-collection.ss")
|
||||
(define name (#%info-lookup 'name))
|
||||
(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 (make-my-key 'update-check))
|
||||
(preferences:set-default update-key #t boolean?)
|
||||
#lang scheme/base
|
||||
(require scheme/file scheme/port net/url setup/plt-installer mred framework
|
||||
"info.ss" "this-collection.ss")
|
||||
|
||||
(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 (in-this-collection "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 name (#%info-lookup 'name))
|
||||
(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 (make-my-key 'update-check))
|
||||
(preferences:set-default update-key #t boolean?)
|
||||
|
||||
(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))))))
|
||||
(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 (in-this-collection "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))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user