993cd40208
For example, a new DrRacket window (with a file named tmp.rkt in the and 356 afterwards. This is under mac os x with, I believe, the default system font sizes. (The file is important because different languages can have different buttons in the toolbar and the filename's length itself can affect the minimum size.) Mostly this change is the addition of a new kind of panel that lets its children have multiple fixed sizes (as opposed to just a single minimum size and (optionally arbitrarily large)) It also adjusts the various toolbar buttons to use this new code. Also, there's a few tweaks to shrink other things that became the limiting factor in shrinking the width of the DrRacket window. Currently, at least for #lang racket programs, the toolbar buttons along the top of the window are the limiting factor (including the save button). With a bogus language (ie, #lang rackeeet), the bottom bar is the limiting factor, since that will have only the Save, Run, and Stop buttons. related to PR 13281
816 lines
32 KiB
Racket
816 lines
32 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class racket/unit racket/file racket/gui/base net/sendurl
|
|
mrlib/switchable-button mrlib/bitmap-label drracket/tool framework
|
|
"info.rkt" "client.rkt" "this-collection.rkt")
|
|
|
|
(provide tool@)
|
|
|
|
(define uninstalled? #f)
|
|
|
|
(define server:port (#%info-lookup 'server:port (lambda () #f)))
|
|
(define-values (server port-no)
|
|
(if server:port
|
|
(let ([m (regexp-match #rx"^([^:]+):([0-9]+)$" server:port)])
|
|
(unless m
|
|
(error 'handin-client
|
|
"Bad configuration ~s, expecting \"server:port\""
|
|
server:port))
|
|
(values (cadr m) (string->number (caddr m))))
|
|
(values #f #f)))
|
|
|
|
(define handin-name (#%info-lookup 'name))
|
|
(define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f)))
|
|
(define web-address (#%info-lookup 'web-address (lambda () #f)))
|
|
|
|
(define password-keep-minutes
|
|
(#%info-lookup 'password-keep-minutes (lambda () #f)))
|
|
|
|
(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 (make-my-key 'submit:username))
|
|
|
|
(preferences:set-default preference-key "" string?)
|
|
(define (remembered-user)
|
|
(preferences:get preference-key))
|
|
(define (remember-user user)
|
|
(preferences:set preference-key user))
|
|
|
|
(define remembered-assignment (make-parameter #f))
|
|
|
|
(define (connect) (handin-connect server port-no))
|
|
|
|
;; parameter-like procedure that keeps the password cached for a few minutes
|
|
(define cached-password
|
|
(let ([passwd #f]
|
|
[timer #f])
|
|
(define protect
|
|
(let ([s (make-semaphore 1)])
|
|
(lambda (thunk)
|
|
(dynamic-wind (lambda () (semaphore-wait s))
|
|
thunk
|
|
(lambda () (semaphore-post s))))))
|
|
(case-lambda
|
|
[() passwd]
|
|
[(new)
|
|
(protect (lambda ()
|
|
(when (and password-keep-minutes
|
|
(not (equal? 0 password-keep-minutes))
|
|
(not (equal? passwd new)))
|
|
(when timer (kill-thread timer))
|
|
(set! passwd new)
|
|
(set! timer (thread
|
|
(lambda ()
|
|
(sleep (* 60 password-keep-minutes))
|
|
(protect (lambda ()
|
|
(set! passwd #f)
|
|
(set! timer #f)))))))))])))
|
|
;; a password entry box that uses the one cached above
|
|
(define cached-passwd%
|
|
(class text-field%
|
|
(define cached (cached-password))
|
|
;; use this instead of a cached password -- to avoid copy/pastes
|
|
;; of a password, and to hide its length
|
|
(define fake-value "CACHED PASSWD")
|
|
(define/override (get-value)
|
|
(or cached (super get-value)))
|
|
(define/override (on-focus on?)
|
|
(if on?
|
|
;; got focus -- clear out bogus contents, if any
|
|
(when cached (send this set-value "") (set! cached #f))
|
|
;; lost focus -- remember a new password, or restore it
|
|
(let ([p (super get-value)])
|
|
(cond [(and p (not (string=? "" p)))
|
|
;; don't behave as if we have a cache: don't clear
|
|
;; the value now, or if we get the focus later
|
|
(set! cached #f)
|
|
(cached-password p)]
|
|
[(cached-password)
|
|
=> (lambda (p)
|
|
(set! cached p)
|
|
(send this set-value fake-value))]))))
|
|
(super-new [init-value (if cached fake-value "")]
|
|
[style '(single password)])))
|
|
|
|
(provide handin-frame%)
|
|
(define handin-frame%
|
|
(class dialog%
|
|
(inherit show is-shown? center)
|
|
(super-new [label handin-dialog-name])
|
|
|
|
(init-field content on-retrieve)
|
|
(define mode
|
|
(cond [(and content on-retrieve) #f]
|
|
[content 'submit]
|
|
[on-retrieve 'retrieve]
|
|
[else (error 'handin-frame "bad initial values")]))
|
|
|
|
(define status
|
|
(new message%
|
|
[label (format "Making secure connection to ~a..." server)]
|
|
[parent this]
|
|
[stretchable-width #t]))
|
|
(define username
|
|
(new text-field%
|
|
[label "Username:"]
|
|
[init-value (remembered-user)]
|
|
[parent this]
|
|
[callback (lambda (t e) (activate-ok))]
|
|
[stretchable-width #t]))
|
|
(define passwd
|
|
(new cached-passwd%
|
|
[label "Password:"]
|
|
[parent this]
|
|
[callback (lambda (t e) (activate-ok))]
|
|
[stretchable-width #t]))
|
|
(define assignment
|
|
(new choice%
|
|
[label "Submit to:"]
|
|
[choices null]
|
|
[parent this]
|
|
[callback (lambda (c e)
|
|
(remembered-assignment
|
|
(send assignment get-string
|
|
(send assignment get-selection))))]
|
|
[stretchable-width #t]))
|
|
|
|
(define button-panel
|
|
(new horizontal-pane%
|
|
[parent this]
|
|
[stretchable-height #f]))
|
|
|
|
(make-object vertical-pane% button-panel) ; spacer
|
|
|
|
(define retrieve?
|
|
(new check-box%
|
|
[label "Retrieve"]
|
|
[parent button-panel]
|
|
[callback (lambda _
|
|
(define r? (send retrieve? get-value))
|
|
(send ok set-label
|
|
(if r? button-label/r button-label/h)))]
|
|
[value (eq? 'retrieve mode)]
|
|
[style (if mode '(deleted) '())]))
|
|
|
|
(define (submit-file)
|
|
(define final-message "Handin successful.")
|
|
(submit-assignment
|
|
connection
|
|
(send username get-value)
|
|
(send passwd get-value)
|
|
(send assignment get-string (send assignment get-selection))
|
|
content
|
|
;; on-commit
|
|
(lambda ()
|
|
(semaphore-wait commit-lock)
|
|
(send status set-label "Committing...")
|
|
(set! committing? #t)
|
|
(semaphore-post commit-lock))
|
|
;; message/message-final/message-box handlers
|
|
(lambda (msg) (send status set-label msg))
|
|
(lambda (msg) (set! final-message msg))
|
|
(lambda (msg styles) (message-box "Handin" msg this styles)))
|
|
(queue-callback
|
|
(lambda ()
|
|
(when abort-commit-dialog (send abort-commit-dialog show #f))
|
|
(send status set-label final-message)
|
|
(set! committing? #f)
|
|
(done-interface))))
|
|
(define (retrieve-file)
|
|
(let ([buf (retrieve-assignment
|
|
connection
|
|
(send username get-value)
|
|
(send passwd get-value)
|
|
(send assignment get-string (send assignment get-selection)))])
|
|
(queue-callback
|
|
(lambda ()
|
|
(done-interface)
|
|
(do-cancel-button)
|
|
(on-retrieve buf)))))
|
|
|
|
(define ok
|
|
(new button%
|
|
[label (case mode
|
|
[(submit) button-label/h]
|
|
[(retrieve) button-label/r]
|
|
[else (string-append " " button-label/h " ")])] ; can change
|
|
[parent button-panel]
|
|
[style '(border)]
|
|
[callback
|
|
(lambda (b e)
|
|
(disable-interface)
|
|
(send status set-label "Handing in...")
|
|
(parameterize ([current-custodian comm-cust])
|
|
(thread
|
|
(lambda ()
|
|
(remember-user (send username get-value))
|
|
(with-handlers ([void (lambda (exn)
|
|
(report-error "Handin failed." exn))])
|
|
(if (send retrieve? get-value)
|
|
(retrieve-file)
|
|
(submit-file)))))))]))
|
|
|
|
(define ok-can-enable? #f)
|
|
(define (activate-ok)
|
|
(send ok enable (and ok-can-enable?
|
|
(not (string=? "" (send username get-value)))
|
|
(not (string=? "" (send passwd get-value))))))
|
|
|
|
(define cancel
|
|
(new button%
|
|
[label "Cancel"]
|
|
[parent button-panel]
|
|
[callback (lambda (b e) (do-cancel-button))]))
|
|
(define (do-cancel-button)
|
|
(let ([go? (begin
|
|
(semaphore-wait commit-lock)
|
|
(if committing?
|
|
(begin
|
|
(semaphore-post commit-lock)
|
|
(send abort-commit-dialog show #t)
|
|
continue-abort?)
|
|
#t))])
|
|
(when go?
|
|
(custodian-shutdown-all comm-cust)
|
|
(show #f))))
|
|
|
|
(define continue-abort? #f)
|
|
(define abort-commit-dialog
|
|
(let ([d (make-object dialog% "Commit in Progress")])
|
|
(make-object message% "The commit action is in progress." d)
|
|
(make-object message% "Cancelling now may or may not work." d)
|
|
(make-object message% "Cancel anyway?" d)
|
|
(let ([b (new horizontal-panel%
|
|
[parent d]
|
|
[stretchable-height #f]
|
|
[alignment '(center center)])])
|
|
(make-object button% "Continue Commit" d
|
|
(lambda (b e) (send d show #f)))
|
|
(make-object button% "Try to Cancel" d
|
|
(lambda (b e)
|
|
(set! continue-abort? #t) (send d show #f))))))
|
|
|
|
(define interface-widgets
|
|
(list ok username passwd assignment retrieve?))
|
|
(define (disable-interface)
|
|
(for ([x (in-list interface-widgets)]) (send x enable #f)))
|
|
(define (enable-interface)
|
|
(for ([x (in-list interface-widgets)]) (send x enable #t) ))
|
|
(define (done-interface)
|
|
(send cancel set-label "Close")
|
|
(send cancel focus))
|
|
|
|
(define (report-error tag exn)
|
|
(queue-callback
|
|
(lambda ()
|
|
(let* ([msg (if (exn? exn)
|
|
(let ([s (exn-message exn)])
|
|
(if (string? s) s (format "~.s" s)))
|
|
(format "~.s" exn))]
|
|
[retry? (regexp-match #rx"bad username or password for" msg)])
|
|
(custodian-shutdown-all comm-cust)
|
|
(set! committing? #f)
|
|
(disable-interface)
|
|
(send status set-label tag)
|
|
(when (is-shown?)
|
|
(message-box "Server Error" msg this)
|
|
(if retry?
|
|
(begin (init-comm) (semaphore-post go-sema) (enable-interface))
|
|
(done-interface)))))))
|
|
|
|
(define go-sema #f)
|
|
(define commit-lock #f)
|
|
(define committing? #f)
|
|
|
|
(define connection #f)
|
|
|
|
(define comm-cust #f)
|
|
(define (init-comm)
|
|
(set! go-sema (make-semaphore 1))
|
|
(set! commit-lock (make-semaphore 1))
|
|
(set! comm-cust (make-custodian))
|
|
(parameterize ([current-custodian comm-cust])
|
|
(thread
|
|
(lambda ()
|
|
(let/ec break
|
|
(with-handlers ([void
|
|
(lambda (exn)
|
|
(report-error "Connection failed." exn)
|
|
(break))])
|
|
(semaphore-wait go-sema)
|
|
(let* ([h (connect)]
|
|
[l (retrieve-active-assignments h)]
|
|
[n (cond [(member (remembered-assignment) l)
|
|
=> (lambda (r) (- (length l) (length r)))]
|
|
[else 0])])
|
|
(when (null? l)
|
|
(handin-disconnect h)
|
|
(error 'handin "there are no active assignments"))
|
|
(set! connection h)
|
|
(for ([assign (in-list l)]) (send assignment append assign))
|
|
(send assignment enable #t)
|
|
(send assignment set-selection n)
|
|
(set! ok-can-enable? #t)
|
|
(activate-ok)
|
|
(send status set-label
|
|
(format "Connected securely for ~a." handin-name)))))))))
|
|
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(do-cancel-button))
|
|
|
|
(init-comm)
|
|
|
|
(send (cond [(string=? "" (send username get-value)) username]
|
|
[(string=? "" (send passwd get-value)) passwd]
|
|
[else ok])
|
|
focus)
|
|
(send ok enable #f) ; disable after focus possibly sent to it
|
|
(send assignment enable #f)
|
|
|
|
(center)
|
|
(show #t)))
|
|
|
|
(provide manage-handin-dialog%)
|
|
(define manage-handin-dialog%
|
|
(class dialog% (init [parent #f])
|
|
(inherit show is-shown? center)
|
|
(super-new [label manage-dialog-name]
|
|
[alignment '(left center)]
|
|
[parent parent])
|
|
(define user-fields (get-user-fields parent))
|
|
|
|
;; === utilities ===
|
|
(define (mk-txt label parent activate-ok)
|
|
(new text-field%
|
|
[label label]
|
|
[parent parent]
|
|
[callback (lambda (t e) (activate-ok))]
|
|
[stretchable-width #t]))
|
|
(define (mk-passwd label parent activate-ok)
|
|
(new text-field%
|
|
[label label]
|
|
[parent parent]
|
|
[callback (lambda (t e) (activate-ok))]
|
|
[style '(single password)]
|
|
[stretchable-width #t]))
|
|
(define (non-empty? . ts)
|
|
(andmap (lambda (t) (not (string=? "" (send t get-value)))) ts))
|
|
(define (same-value t1 t2)
|
|
(string=? (send t1 get-value) (send t2 get-value)))
|
|
(define (report-error tag exn)
|
|
(queue-callback
|
|
(lambda ()
|
|
(custodian-shutdown-all comm-cust)
|
|
(send status set-label tag)
|
|
(when (is-shown?)
|
|
(message-box
|
|
"Server Error"
|
|
(if (exn? exn)
|
|
(let ([s (exn-message exn)]) (if (string? s) s (format "~.s" s)))
|
|
(format "~.s" exn))
|
|
this)
|
|
(set! comm-cust (make-custodian))))))
|
|
(define comm-cust (make-custodian))
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(custodian-shutdown-all comm-cust))
|
|
;; Too-long fields can't damage the server, but they might result in
|
|
;; confusing errors due to safety cut-offs on the server side.
|
|
(define (check-length field size name k)
|
|
(when ((string-length (send field get-value)) . > . size)
|
|
(message-box "Error"
|
|
(format "The ~a must be no longer than ~a characters."
|
|
name size))
|
|
(k (void))))
|
|
(define (do-change/add new? username)
|
|
(let/ec break
|
|
(check-length username 50 "Username" break)
|
|
(let* ([pw1 (if new? new-passwd add-passwd)]
|
|
[pw2 (if new? new-passwd2 add-passwd2)]
|
|
[l1 (regexp-replace #rx" *:$" (send pw1 get-label) "")]
|
|
[l2 (regexp-replace #rx" *:$" (send pw2 get-label) "")])
|
|
(check-length pw1 50 l1 break)
|
|
;; not really needed, but leave just in case
|
|
(unless (string=? (send pw1 get-value) (send pw2 get-value))
|
|
(message-box
|
|
"Password Error"
|
|
(format "The \"~a\" and \"~a\" passwords are not the same." l1 l2))
|
|
(break (void))))
|
|
(for ([t (in-list (if new? add-user-fields change-user-fields))]
|
|
[f (in-list (or user-fields '()))])
|
|
(check-length t 100 f break))
|
|
(send tabs enable #f)
|
|
(parameterize ([current-custodian comm-cust])
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers ([void (lambda (exn)
|
|
(send tabs enable #t)
|
|
(report-error
|
|
(format "~a failed."
|
|
(if new? "Creation" "Update"))
|
|
exn))])
|
|
(remember-user (send username get-value))
|
|
(send status set-label "Making secure connection...")
|
|
(let ([h (connect)])
|
|
(define (run proc . fields)
|
|
(apply proc h
|
|
(let loop ([x fields])
|
|
(if (list? x) (map loop x) (send x get-value)))))
|
|
(send status set-label
|
|
(if new? "Creating user..." "Updating server..."))
|
|
(if new?
|
|
(run submit-addition username add-passwd add-user-fields)
|
|
(run submit-info-change username old-passwd new-passwd
|
|
change-user-fields)))
|
|
(send status set-label "Success.")
|
|
(send cancel set-label "Close")))))))
|
|
(define (do-retrieve username)
|
|
(send tabs enable #f)
|
|
(parameterize ([current-custodian comm-cust])
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers ([void (lambda (exn)
|
|
(send tabs enable #t)
|
|
(report-error "Retrieve failed." exn))])
|
|
(remember-user (send username get-value))
|
|
(send status set-label "Making secure connection...")
|
|
(let ([h (connect)])
|
|
(define (run proc . fields)
|
|
(apply proc h
|
|
(let loop ([x fields])
|
|
(if (list? x) (map loop x) (send x get-value)))))
|
|
(send status set-label "Retrieving information...")
|
|
(let ([vals (run retrieve-user-info username old-passwd)])
|
|
(send status set-label "Success, you can now edit fields.")
|
|
(send tabs enable #t)
|
|
(for ([f change-user-fields]
|
|
[val vals])
|
|
(send f set-value val))
|
|
(activate-change))))))))
|
|
|
|
;; === toplevel gadgets ===
|
|
(define status
|
|
(new message%
|
|
[label (if user-fields
|
|
(format "Manage ~a handin account at ~a."
|
|
handin-name server)
|
|
"No connection to server!")]
|
|
[parent this]
|
|
[stretchable-width #t]))
|
|
(define (set-active-tab n)
|
|
(send new-user-box show #f)
|
|
(send old-user-box show #f)
|
|
(send un/install-box show #f)
|
|
(send (if user-fields
|
|
(case n
|
|
[(0) new-user-box]
|
|
[(1) old-user-box]
|
|
[(2) un/install-box]
|
|
[else (error "internal error")])
|
|
un/install-box)
|
|
show #t))
|
|
(define tabs
|
|
(let* ([names (list (if multifile? "Un/Install" "Uninstall"))]
|
|
[names (if user-fields
|
|
`("New User" "Change Info" ,@names) names)]
|
|
[callback (lambda _ (set-active-tab (send tabs get-selection)))])
|
|
(new tab-panel% [parent this] [choices names] [callback callback])))
|
|
(define single (new panel:single% [parent tabs]))
|
|
(define button-panel
|
|
(new horizontal-pane% [parent this] [stretchable-height #f]))
|
|
(make-object vertical-pane% button-panel) ; spacer
|
|
(define cancel
|
|
(new button%
|
|
[label "Cancel"] [parent button-panel]
|
|
[callback (lambda (b e)
|
|
(custodian-shutdown-all comm-cust)
|
|
(show #f))]))
|
|
|
|
;; === change existing info tab ===
|
|
(define (activate-change)
|
|
(define an-extra-non-empty? (ormap non-empty? change-user-fields))
|
|
(send retrieve-old-info-button enable
|
|
(non-empty? old-username old-passwd))
|
|
(send change-button enable
|
|
(and (same-value new-passwd new-passwd2)
|
|
(non-empty? old-username old-passwd)
|
|
(or (non-empty? new-passwd) an-extra-non-empty?)))
|
|
(send change-button set-label
|
|
(if an-extra-non-empty? "Change Info" "Set Password")))
|
|
(define old-user-box (new vertical-panel%
|
|
[parent single] [alignment '(center center)]))
|
|
(define old-username (mk-txt "Username:" old-user-box activate-change))
|
|
(send old-username set-value (remembered-user))
|
|
(define old-passwd
|
|
(new cached-passwd%
|
|
[label "Old Password:"]
|
|
[parent old-user-box]
|
|
[callback (lambda (t e) (activate-change))]
|
|
[stretchable-width #t]))
|
|
(define change-user-fields
|
|
(map (lambda (f)
|
|
(mk-txt (string-append f ":") old-user-box activate-change))
|
|
(or user-fields '())))
|
|
(define new-passwd
|
|
(mk-passwd "New Password:" old-user-box activate-change))
|
|
(define new-passwd2
|
|
(mk-passwd "New Password again:" old-user-box activate-change))
|
|
(define-values (retrieve-old-info-button change-button)
|
|
(let ([p (new horizontal-pane%
|
|
[parent old-user-box]
|
|
[stretchable-height #f]
|
|
[alignment '(center center)])])
|
|
(make-object vertical-pane% p)
|
|
(values
|
|
(begin0 (new button%
|
|
[label "Get Current Info"] [parent p]
|
|
[callback (lambda (b e) (do-retrieve old-username))])
|
|
(make-object vertical-pane% p))
|
|
(begin0 (new button%
|
|
[label "Set Password"] [parent p] [style '(border)]
|
|
[callback (lambda (b e)
|
|
(do-change/add #f old-username))])
|
|
(make-object vertical-pane% p)))))
|
|
|
|
;; === register new user tab ===
|
|
(define (activate-new)
|
|
(send new-button enable
|
|
(and (apply non-empty? new-username add-passwd add-passwd2
|
|
add-user-fields)
|
|
(same-value add-passwd add-passwd2))))
|
|
(define new-user-box (new vertical-panel%
|
|
[parent single] [alignment '(center center)]))
|
|
(define new-username (mk-txt "Username:" new-user-box activate-new))
|
|
(send new-username set-value (remembered-user))
|
|
(define add-user-fields
|
|
(map (lambda (f)
|
|
(mk-txt (string-append f ":") new-user-box activate-new))
|
|
(or user-fields '())))
|
|
(define add-passwd
|
|
(mk-passwd "Password:" new-user-box activate-new))
|
|
(define add-passwd2
|
|
(mk-passwd "Password again:" new-user-box activate-new))
|
|
(define new-button (new button%
|
|
[label "Add User"] [parent new-user-box]
|
|
[callback (lambda (b e)
|
|
(do-change/add #t new-username))]
|
|
[style '(border)]))
|
|
|
|
;; === uninstall client, install standalone client ===
|
|
(define un/install-box
|
|
(new vertical-panel% [parent single] [alignment '(center center)]))
|
|
(define uninstall-button
|
|
(new button%
|
|
[label (format "Uninstall ~a Handin" handin-name)]
|
|
[parent un/install-box]
|
|
[callback
|
|
(lambda (b e)
|
|
(with-handlers ([void (lambda (exn)
|
|
(report-error "Uninstall failed." exn))])
|
|
(delete-directory/files (in-this-collection))
|
|
(set! uninstalled? #t)
|
|
(send uninstall-button enable #f)
|
|
(message-box
|
|
"Uninstall"
|
|
(format "The ~a tool has been uninstalled. ~a~a"
|
|
handin-name
|
|
"The Handin button and associated menu items will"
|
|
" not appear after you restart DrRacket.")
|
|
this)
|
|
(send this show #f)))]))
|
|
(send uninstall-button enable (not uninstalled?))
|
|
(define install-standalone-button
|
|
(and multifile?
|
|
(new button%
|
|
[label (format "Install Standalone ~a Handin" handin-name)]
|
|
[parent un/install-box]
|
|
[callback
|
|
(lambda (b e)
|
|
(define (launcher sym)
|
|
(dynamic-require `launcher sym))
|
|
(let* ([exe (let-values
|
|
([(dir name dir?)
|
|
(split-path
|
|
((launcher 'mred-program-launcher-path)
|
|
(format "~a Handin" handin-name)))])
|
|
(path->string name))]
|
|
[dir (get-directory
|
|
(format "Choose a directory to create the ~s~a"
|
|
exe " executable in")
|
|
#f)])
|
|
(when (and dir (directory-exists? dir))
|
|
(parameterize ([current-directory dir])
|
|
(when (or (not (file-exists? exe))
|
|
(eq? 'ok
|
|
(message-box
|
|
"File Exists"
|
|
(format
|
|
"The ~s executable already exists, ~a"
|
|
exe "it will be overwritten")
|
|
this '(ok-cancel caution))))
|
|
((launcher 'make-mred-launcher)
|
|
(list "-le-" (format "~a/handin-multi"
|
|
this-collection-name)
|
|
"(multifile-handin)")
|
|
(build-path dir exe))
|
|
(message-box "Standalone Executable"
|
|
(format "~s created" exe)
|
|
this)
|
|
(send this show #f))))))])))
|
|
|
|
;; === initialize the whole thing ===
|
|
(activate-new)
|
|
(activate-change)
|
|
(center)
|
|
(queue-callback
|
|
(lambda ()
|
|
(define n (cond [(not user-fields) 0]
|
|
[(equal? "" (remembered-user)) 0]
|
|
[else 1]))
|
|
(set-active-tab n)
|
|
(send tabs set-selection n)))
|
|
(show #t)))
|
|
|
|
;; A simple dialog during connection, with an option to cancel (used
|
|
;; by `get-user-fields' below, since its value is needed to
|
|
;; construct the above dialog).
|
|
(define connection-dialog%
|
|
(class dialog% (init receiver [parent #f])
|
|
(inherit show is-shown? center)
|
|
(super-new [label manage-dialog-name]
|
|
[alignment '(right center)]
|
|
[parent parent])
|
|
(define status
|
|
(new message% [label "Connecting to server..."]
|
|
[parent this]
|
|
[stretchable-width #t]))
|
|
(define comm-cust (make-custodian))
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(custodian-shutdown-all comm-cust))
|
|
(define button
|
|
(new button% [label "Cancel"] [parent this]
|
|
[callback (lambda (b e)
|
|
(custodian-shutdown-all comm-cust)
|
|
(show #f))]
|
|
[style '(border)]))
|
|
(send button focus)
|
|
(parameterize ([current-custodian comm-cust])
|
|
(thread
|
|
(lambda ()
|
|
(unless (with-handlers ([void (lambda (_) #f)])
|
|
(receiver (connect)) #t)
|
|
(begin (send status set-label "Connection failure!")
|
|
;; (send button enable #f)
|
|
(sleep 5)))
|
|
(queue-callback (lambda () (show #f))))))
|
|
(center)
|
|
(show #t)))
|
|
|
|
(define cached-user-fields #f)
|
|
(define (get-user-fields parent)
|
|
(unless cached-user-fields
|
|
(new connection-dialog%
|
|
[receiver (lambda (h)
|
|
(set! cached-user-fields (retrieve-user-fields h)))]
|
|
[parent parent]))
|
|
cached-user-fields)
|
|
|
|
(define (scale-by-half file)
|
|
(let* ([bm (make-object bitmap% file 'unknown/mask)]
|
|
[w (send bm get-width)]
|
|
[h (send bm get-height)]
|
|
[bm2 (make-object bitmap% (quotient w 2) (quotient h 2))]
|
|
[mbm2 (and (send bm get-loaded-mask)
|
|
(make-object bitmap% (quotient w 2) (quotient h 2)))]
|
|
[mdc (make-object bitmap-dc% bm2)])
|
|
(send mdc draw-bitmap-section-smooth bm
|
|
0 0 (quotient w 2) (quotient h 2)
|
|
0 0 w h)
|
|
(send mdc set-bitmap #f)
|
|
(when mbm2
|
|
(send mdc set-bitmap mbm2)
|
|
(send mdc draw-bitmap-section-smooth (send bm get-loaded-mask)
|
|
0 0 (quotient w 2) (quotient h 2)
|
|
0 0 w h)
|
|
(send mdc set-bitmap #f)
|
|
(send bm2 set-loaded-mask mbm2))
|
|
bm2))
|
|
|
|
(define handin-icon (scale-by-half (in-this-collection "icon.png")))
|
|
|
|
(define (editors->string editors)
|
|
(let* ([base (make-object editor-stream-out-bytes-base%)]
|
|
[stream (make-object editor-stream-out% base)])
|
|
(write-editor-version stream base)
|
|
(write-editor-global-header stream)
|
|
(for ([ed (in-list editors)]) (send ed write-to-file stream))
|
|
(write-editor-global-footer stream)
|
|
(send base get-bytes)))
|
|
|
|
(define (string->editor! str defs)
|
|
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
|
[stream (make-object editor-stream-in% base)])
|
|
(read-editor-version stream base #t)
|
|
(read-editor-global-header stream)
|
|
(send* defs (begin-edit-sequence #f)
|
|
(erase) (read-from-file stream)
|
|
(end-edit-sequence))
|
|
(read-editor-global-footer stream)))
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drracket:tool^)
|
|
(export drracket:tool-exports^)
|
|
|
|
(define phase1 void)
|
|
(define phase2
|
|
(if updater?
|
|
(dynamic-require `(lib "updater.rkt" ,this-collection-name) 'bg-update)
|
|
void))
|
|
|
|
(define tool-button-label (bitmap-label-maker button-label/h handin-icon))
|
|
|
|
(define (make-new-unit-frame% super%)
|
|
(class super%
|
|
(inherit get-button-panel
|
|
get-definitions-text
|
|
get-interactions-text)
|
|
(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)
|
|
(new manage-handin-dialog% [parent this]))])
|
|
(when multifile?
|
|
(new menu-item%
|
|
[label (format "Submit multiple ~a Files..." handin-name)]
|
|
[parent file-menu]
|
|
[callback (lambda (m e)
|
|
((dynamic-require
|
|
`(lib "handin-multi.rkt" ,this-collection-name)
|
|
'multifile-handin)))]))
|
|
(when updater?
|
|
(new menu-item%
|
|
[label (format "Update ~a plugin..." handin-name)]
|
|
[parent file-menu]
|
|
[callback
|
|
(lambda (m e)
|
|
((dynamic-require `(lib "updater.rkt" ,this-collection-name)
|
|
'update)
|
|
#f #t))])) ; no parent
|
|
(new separator-menu-item% [parent file-menu]))
|
|
|
|
(define/override (help-menu:after-about menu)
|
|
(when web-menu-name
|
|
(new menu-item%
|
|
[label web-menu-name]
|
|
[parent menu]
|
|
[callback (lambda (item evt) (send-url web-address))]))
|
|
(super help-menu:after-about menu))
|
|
|
|
(define client-panel
|
|
(new panel:vertical-discrete-sizes% (parent (get-button-panel))))
|
|
|
|
(define client-button
|
|
(new switchable-button%
|
|
[label button-label/h]
|
|
[bitmap handin-icon]
|
|
[parent client-panel]
|
|
[callback
|
|
(lambda (button)
|
|
(let ([content (editors->string
|
|
(list (get-definitions-text)
|
|
(get-interactions-text)))])
|
|
(new handin-frame%
|
|
[parent this]
|
|
[content content]
|
|
[on-retrieve
|
|
(lambda (buf)
|
|
(string->editor!
|
|
buf
|
|
(send (drracket:unit:open-drscheme-window)
|
|
get-editor)))])))]))
|
|
|
|
(inherit register-toolbar-button)
|
|
(register-toolbar-button client-button #:number -1000)
|
|
|
|
(send (get-button-panel) change-children
|
|
(lambda (l) (cons client-panel (remq client-panel l))))))
|
|
|
|
(when (and server port-no)
|
|
(drracket:get/extend:extend-unit-frame make-new-unit-frame% #f))))
|