547 lines
17 KiB
Scheme
547 lines
17 KiB
Scheme
(module tool mzscheme
|
|
(require (lib "mred.ss" "mred")
|
|
(lib "class.ss")
|
|
(lib "unitsig.ss")
|
|
(lib "tool.ss" "drscheme")
|
|
(lib "etc.ss")
|
|
(lib "file.ss")
|
|
(lib "framework.ss" "framework")
|
|
(lib "sendurl.ss" "net")
|
|
(lib "bitmap-label.ss" "mrlib")
|
|
"client.ss"
|
|
"info.ss"
|
|
;; Temporary hack for test suite in separate window:
|
|
(lib "extension.ss" "test-suite"))
|
|
|
|
(provide tool@)
|
|
|
|
(define uninstalled? #f)
|
|
|
|
(define server:port
|
|
(#%info-lookup 'server:port (lambda () (getenv "PLT_HANDIN_SERVER_PORT"))))
|
|
(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 this-collection (#%info-lookup 'collection))
|
|
(define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f)))
|
|
(define web-address (#%info-lookup 'web-address (lambda () #f)))
|
|
|
|
(define handin-dialog-name (string-append handin-name " Handin"))
|
|
(define button-label (string-append handin-name " Handin"))
|
|
(define manage-dialog-name (string-append handin-name " Handin Account"))
|
|
|
|
(define preference-key
|
|
(string->symbol (format "submit:username:~a" this-collection)))
|
|
|
|
(preferences:set-default preference-key "" string?)
|
|
(define (remembered-user)
|
|
(preferences:get preference-key))
|
|
(define (remember-user user)
|
|
(preferences:set preference-key user))
|
|
|
|
(define (connect)
|
|
(handin-connect
|
|
server port-no
|
|
(build-path (collection-path this-collection) "server-cert.pem")))
|
|
|
|
(define handin-frame%
|
|
(class dialog%
|
|
(inherit show is-shown? center)
|
|
(super-new [label handin-dialog-name])
|
|
|
|
(init-field content)
|
|
|
|
(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 text-field%
|
|
[label "Password:"]
|
|
[parent this]
|
|
[callback (lambda (t e) (activate-ok))]
|
|
[style '(single password)]
|
|
[stretchable-width #t]))
|
|
(define assignment (new choice%
|
|
[label "Assignment:"]
|
|
[choices null]
|
|
[parent this]
|
|
[callback void]
|
|
[stretchable-width #t]))
|
|
|
|
(define button-panel (new horizontal-pane%
|
|
[parent this]
|
|
[stretchable-height #f]))
|
|
(make-object vertical-pane% button-panel) ; spacer
|
|
(define ok (new button%
|
|
[label button-label]
|
|
[parent button-panel]
|
|
[callback (lambda (b e)
|
|
(disable-interface)
|
|
(send status set-label "Handing in...")
|
|
(parameterize ([current-custodian
|
|
comm-cust])
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers ([void
|
|
(lambda (exn)
|
|
(report-error
|
|
"Handin failed."
|
|
exn))])
|
|
(remember-user (send username get-value))
|
|
(let ([result-msg
|
|
(submit-assignment
|
|
connection
|
|
(send username get-value)
|
|
(send passwd get-value)
|
|
(send assignment
|
|
get-string
|
|
(send assignment get-selection))
|
|
content
|
|
(lambda ()
|
|
(semaphore-wait commit-lock)
|
|
(send status set-label "Comitting...")
|
|
(set! committing? #t)
|
|
(semaphore-post commit-lock)))])
|
|
(queue-callback
|
|
(lambda ()
|
|
(when abort-commit-dialog
|
|
(send abort-commit-dialog show #f))
|
|
(send status set-label "Handin successful.")
|
|
(set! committing? #f)
|
|
(done-interface)
|
|
(when result-msg
|
|
(message-box "Handin Result"
|
|
result-msg
|
|
this
|
|
'(ok)))))))))))]
|
|
[style '(border)]))
|
|
|
|
(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 (disable-interface)
|
|
(send ok enable #f)
|
|
(send username enable #f)
|
|
(send passwd enable #f)
|
|
(send assignment enable #f))
|
|
(define (enable-interface)
|
|
(send ok enable #t)
|
|
(send username enable #t)
|
|
(send passwd enable #t)
|
|
(send assignment enable #t)
|
|
(send passwd focus))
|
|
(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 "~e" s)))
|
|
(format "~e" 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 escape
|
|
(with-handlers ([void
|
|
(lambda (exn)
|
|
(report-error
|
|
"Connection failed."
|
|
exn)
|
|
(escape))])
|
|
(semaphore-wait go-sema)
|
|
(let-values ([(h l) (connect)])
|
|
(when (null? l)
|
|
(error 'handin "there are no active assignments"))
|
|
(set! connection h)
|
|
(for-each (lambda (assign)
|
|
(send assignment append assign))
|
|
l)
|
|
(send assignment enable #t)
|
|
(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))
|
|
|
|
(send ok enable #f)
|
|
(send assignment enable #f)
|
|
|
|
(init-comm)
|
|
(send passwd focus)
|
|
(center)
|
|
(show #t)))
|
|
|
|
(define (manage-handin-account)
|
|
(new
|
|
(class dialog%
|
|
(inherit show is-shown? center)
|
|
(super-new [label manage-dialog-name]
|
|
[alignment '(left center)])
|
|
|
|
(define status
|
|
(new message%
|
|
[label (format "Manage ~a handin account at ~a." handin-name server)]
|
|
[parent this]
|
|
[stretchable-width #t]))
|
|
|
|
(define tabs
|
|
(new tab-panel%
|
|
[parent this]
|
|
[choices '("New User" "Change Password" "Uninstall")]
|
|
[callback
|
|
(lambda (tp e)
|
|
(send single active-child
|
|
(list-ref (list new-user-box old-user-box uninstall-box)
|
|
(send tabs get-selection))))]))
|
|
|
|
(define single (new panel:single% [parent tabs]))
|
|
|
|
(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? t)
|
|
(not (string=? "" (send t get-value))))
|
|
|
|
(define (activate-change)
|
|
(send change-button enable
|
|
(and (non-empty? old-username)
|
|
(non-empty? old-passwd)
|
|
(non-empty? new-passwd)
|
|
(non-empty? confirm-passwd))))
|
|
(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 (mk-passwd "Old:" old-user-box activate-change))
|
|
(define new-passwd (mk-passwd "New:" old-user-box activate-change))
|
|
(define confirm-passwd (mk-passwd "New again:" old-user-box activate-change))
|
|
(define change-button (new button%
|
|
[label "Set Password"]
|
|
[parent old-user-box]
|
|
[callback
|
|
(lambda (b e)
|
|
(do-change/add #f old-username b e))]
|
|
[style '(border)]))
|
|
|
|
(define (activate-new)
|
|
(send new-button enable
|
|
(and (non-empty? new-username)
|
|
(non-empty? full-name)
|
|
(non-empty? student-id)
|
|
(non-empty? email)
|
|
(non-empty? add-passwd))))
|
|
(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 full-name (mk-txt "Full Name:" new-user-box activate-new))
|
|
(define student-id (mk-txt "ID:" new-user-box activate-new))
|
|
(define email (mk-txt "Email:" new-user-box activate-new))
|
|
(define add-passwd (mk-passwd "Password:" 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 b e))]
|
|
[style '(border)]))
|
|
|
|
(define uninstall-box (new vertical-panel%
|
|
[parent single]
|
|
[alignment '(center center)]))
|
|
(define uninstall-button (new button%
|
|
[label (format "Uninstall ~a" handin-name)]
|
|
[parent uninstall-box]
|
|
[callback
|
|
(lambda (b e)
|
|
(let ([dir (collection-path this-collection)])
|
|
(with-handlers ([void (lambda (exn)
|
|
(report-error
|
|
"Uninstall failed."
|
|
exn))])
|
|
(delete-directory/files dir)
|
|
(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 DrScheme.")))))]))
|
|
(send uninstall-button enable (not uninstalled?))
|
|
|
|
(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 "~e" s))))
|
|
this)
|
|
(set! comm-cust (make-custodian))))))
|
|
|
|
(define comm-cust (make-custodian))
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(custodian-shutdown-all comm-cust))
|
|
|
|
(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))]))
|
|
|
|
;; 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 b e)
|
|
(let/ec k
|
|
(unless new?
|
|
(check-length new-passwd 50 "New password" k)
|
|
(when (not (string=? (send new-passwd get-value)
|
|
(send confirm-passwd get-value)))
|
|
(message-box "Password Error"
|
|
"The \"New\" and \"New again\" passwords are not the same.")
|
|
(k (void))))
|
|
(when new?
|
|
(check-length username 50 "Username" k)
|
|
(check-length full-name 100 "Full Name" k)
|
|
(check-length student-id 100 "ID" k)
|
|
(check-length email 100 "Email" k)
|
|
(check-length add-passwd 50 "Password" k))
|
|
(send tabs enable #f)
|
|
(parameterize ([current-custodian comm-cust])
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers ([void (lambda (exn)
|
|
(send tabs enable #t)
|
|
(report-error "Update failed." exn))])
|
|
(remember-user (send username get-value))
|
|
(send status set-label "Making secure connection...")
|
|
(let-values ([(h l) (connect)])
|
|
(define (run proc . fields)
|
|
(apply proc h (map (lambda (f) (send f get-value))
|
|
fields)))
|
|
(send status set-label "Updating server...")
|
|
(if new?
|
|
(run submit-addition
|
|
username full-name student-id email add-passwd)
|
|
(run submit-password-change
|
|
username old-passwd new-passwd)))
|
|
(send status set-label "Success.")
|
|
(send cancel set-label "Close")))))))
|
|
|
|
(send new-user-box show #f)
|
|
(send old-user-box show #f)
|
|
(send uninstall-box show #f)
|
|
(let ([new? (equal? "" (remembered-user))])
|
|
(send (if new? new-user-box old-user-box) show #t)
|
|
(send tabs set-selection (if new? 0 1)))
|
|
(activate-new)
|
|
(activate-change)
|
|
(center)
|
|
(show #t))))
|
|
|
|
(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
|
|
(build-path (collection-path 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-each (lambda (ed)
|
|
(send ed write-to-file stream)
|
|
(send ed write-to-file stream))
|
|
editors)
|
|
(write-editor-global-footer stream)
|
|
(send base get-bytes)))
|
|
|
|
(add-test-suite-extension
|
|
"Handin"
|
|
handin-icon
|
|
(lambda (parent editor)
|
|
(let ([content (editors->string (list editor))])
|
|
(new handin-frame% [parent parent] [content content]))))
|
|
|
|
(define tool@
|
|
(unit/sig drscheme:tool-exports^
|
|
(import drscheme:tool^)
|
|
|
|
(define phase1 void)
|
|
(define phase2 void)
|
|
|
|
(define tool-button-label (bitmap-label-maker button-label 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)
|
|
(new menu-item%
|
|
(label (format "Manage ~a Handin Account..." handin-name))
|
|
(parent file-menu)
|
|
(callback (lambda (m e) (manage-handin-account))))
|
|
(super file-menu:between-open-and-revert 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 button
|
|
(new button%
|
|
[label (tool-button-label this)]
|
|
[parent (get-button-panel)]
|
|
[callback (lambda (button evt)
|
|
(let ([content (editors->string
|
|
(list (get-definitions-text)
|
|
(get-interactions-text)))])
|
|
(new handin-frame% [parent this] [content content])))]
|
|
[style '(deleted)]))
|
|
(send (get-button-panel) change-children
|
|
(lambda (l) (cons button l)))))
|
|
|
|
(when (and server port-no)
|
|
(drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f)))))
|