* The protocol is changed, so its identifier is changed for safety
(from 'original to 'ver1). * The client gets the list of extra fields from the server (when the dialog is used for the first time), the full-name, ID, and email fields are now part of this description which is in the server configuration file * The network protocol has a generic initial part when clients set arbitrary key/values that are later used for actual actions * In the submission dialog, there is a checkbox that makes it retrieve the submitted work instead of sending a new one. The retrieved contents will pop up in a new DrScheme frame. The file that is retrieved is the newest WXME file that is found in the student's main submission directory. * The hack of returning a list from the checker is not needed now -- it is possible to send text messages that are displayed on the handin dialog and it is also possible to send message-boxes and get the result that the client returns after getting the user response. This is a much better generalization of the single final popup that was enabled by the list hack. * When registering, a second password for verification is required. * It is now possible to edit any information field, with a configuration entry that locks by default any such changes. * It is now possible to standard Unix encrypted passwords instead of MD5 hashes -- so a "users.ss" can be made from a plain /etc/passwd file. svn: r995
This commit is contained in:
Eli Barzilay
parent
46c6c9c3cc
commit
6d152fb925
|
|
@ -1,11 +1,14 @@
|
|||
|
||||
(module client mzscheme
|
||||
(require (lib "mzssl.ss" "openssl"))
|
||||
|
||||
(provide handin-connect
|
||||
retrieve-extra-fields
|
||||
retrieve-active-assignments
|
||||
submit-assignment
|
||||
retrieve-assignment
|
||||
submit-addition
|
||||
submit-password-change)
|
||||
submit-info-change
|
||||
retrieve-user-info)
|
||||
|
||||
(define-struct handin (r w))
|
||||
|
||||
|
|
@ -13,6 +16,14 @@
|
|||
(for-each (lambda (x) (write x port) (newline port)) xs)
|
||||
(flush-output port))
|
||||
|
||||
(define (close-handin-ports h)
|
||||
(close-input-port (handin-r h))
|
||||
(close-output-port (handin-w h)))
|
||||
|
||||
(define (wait-for-ok r who)
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'ok) (error 'handin-connect "~a error: ~a" who v))))
|
||||
|
||||
(define (handin-connect server port pem)
|
||||
(let ([ctx (ssl-make-client-context)])
|
||||
(ssl-set-verify! ctx #t)
|
||||
|
|
@ -22,68 +33,118 @@
|
|||
(let ([s (read-bytes 6 r)])
|
||||
(unless (equal? #"handin" s)
|
||||
(error 'handin-connect "bad handshake from server: ~e" s)))
|
||||
;; Tell server protocol = 'original:
|
||||
(write+flush w 'original)
|
||||
;; Tell server protocol = 'ver1:
|
||||
(write+flush w 'ver1)
|
||||
;; One more sanity check: server recognizes protocol:
|
||||
(let ([s (read r)])
|
||||
(unless (eq? s 'original)
|
||||
(unless (eq? s 'ver1)
|
||||
(error 'handin-connect "bad protocol from server: ~e" s)))
|
||||
;; Return connection and list of active assignments:
|
||||
(values (make-handin r w)
|
||||
(let ([v (read r)])
|
||||
(unless (and (list? v)
|
||||
(andmap string? v))
|
||||
(error 'handin-connect "failed to get active-assignment list from server"))
|
||||
v)))))
|
||||
;; Return connection:
|
||||
(make-handin r w))))
|
||||
|
||||
(define (submit-assignment h username passwd assignment content on-commit)
|
||||
(let ([r (handin-r h)]
|
||||
[w (handin-w h)])
|
||||
(write+flush w username passwd assignment)
|
||||
(define (retrieve-extra-fields h)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w 'get-extra-fields 'bye)
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'ok)
|
||||
(error 'handin-connect "login error: ~a" v)))
|
||||
(unless (and (list? v)
|
||||
(andmap (lambda (l) (and (pair? l) (string? (car l)))) v))
|
||||
(error 'handin-connect
|
||||
"failed to get extra-fields list from server"))
|
||||
(wait-for-ok r "get-extra-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 'handin-connect
|
||||
"failed to get active-assignment list from server"))
|
||||
v)))
|
||||
|
||||
(define (submit-assignment h username passwd assignment content
|
||||
on-commit message message-box)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(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 'handin-connect "upload error: ~a" v)))
|
||||
(fprintf w "$")
|
||||
(display "$" w)
|
||||
(display content w)
|
||||
(flush-output w)
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'confirm)
|
||||
(error 'handin-connect "submit error: ~a" v)))
|
||||
;; 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 loop ()
|
||||
(let ([v (read r)])
|
||||
(case v
|
||||
[(confirm) #t]
|
||||
[(message) (message (read r)) (loop)]
|
||||
[(message-box)
|
||||
(write+flush w (message-box (read r) (read r))) (loop)]
|
||||
[else (error 'handin-connect "submit error: ~a" v)])))
|
||||
(on-commit)
|
||||
(write+flush w 'check)
|
||||
(let ([result-msg
|
||||
(let ([v (read r)])
|
||||
(cond
|
||||
[(eq? v 'done) #f]
|
||||
[(and (pair? v) (eq? (car v) 'result))
|
||||
(cadr v)]
|
||||
[else
|
||||
(error 'handin-connect "commit probably unsucccesful: ~e" v)]))])
|
||||
(close-input-port r)
|
||||
(close-output-port w)
|
||||
result-msg)))
|
||||
(wait-for-ok r "commit")
|
||||
(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 'handin-connect "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 full-name id email passwd)
|
||||
(define (submit-addition h username passwd extra-fields)
|
||||
(let ([r (handin-r h)] [w (handin-w h)])
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password passwd
|
||||
'set 'extra-fields extra-fields
|
||||
'create-user)
|
||||
(wait-for-ok r "create-user")
|
||||
(close-handin-ports h)))
|
||||
|
||||
(define (submit-info-change h username old-passwd new-passwd extra-fields)
|
||||
(let ([r (handin-r h)]
|
||||
[w (handin-w h)])
|
||||
(write+flush w username 'create full-name id email passwd)
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'ok)
|
||||
(error 'handin-connect "update error: ~a" v)))
|
||||
(close-input-port r)
|
||||
(close-output-port w)))
|
||||
(write+flush w
|
||||
'set 'username/s username
|
||||
'set 'password old-passwd
|
||||
'set 'new-password new-passwd
|
||||
'set 'extra-fields extra-fields
|
||||
'change-user-info)
|
||||
(wait-for-ok r "change-user-info")
|
||||
(close-handin-ports h)))
|
||||
|
||||
(define (submit-password-change h username old-passwd new-passwd)
|
||||
(let ([r (handin-r h)]
|
||||
[w (handin-w h)])
|
||||
(write+flush w username old-passwd 'change new-passwd)
|
||||
(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 (eq? v 'ok)
|
||||
(error 'handin-connect "update error: ~a" v)))
|
||||
(close-input-port r)
|
||||
(close-output-port w))))
|
||||
(unless (and (list? v) (andmap string? v))
|
||||
(error 'handin-connect "failed to get user-info list from server"))
|
||||
(wait-for-ok r "get-user-info")
|
||||
(close-handin-ports h)
|
||||
v)))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@
|
|||
(inherit show is-shown? center)
|
||||
(super-new [label handin-dialog-name])
|
||||
|
||||
(init-field content)
|
||||
(init-field content open-drscheme-window)
|
||||
|
||||
(define status (new message%
|
||||
[label (format "Making secure connection to ~a..." server)]
|
||||
|
|
@ -86,49 +86,62 @@
|
|||
[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 retrieve?
|
||||
(new check-box%
|
||||
[label "Retrieve"]
|
||||
[parent button-panel]))
|
||||
|
||||
(define (submit-file)
|
||||
(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))
|
||||
(lambda (msg) (send status set-label 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 "Handin successful.")
|
||||
(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)
|
||||
(string->editor! buf (send (open-drscheme-window) get-editor))))))
|
||||
|
||||
(define ok
|
||||
(new button%
|
||||
[label button-label]
|
||||
[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)
|
||||
|
|
@ -215,26 +228,26 @@
|
|||
(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)))))))))
|
||||
(thread
|
||||
(lambda ()
|
||||
(let/ec escape
|
||||
(with-handlers ([void
|
||||
(lambda (exn)
|
||||
(report-error "Connection failed." exn)
|
||||
(escape))])
|
||||
(semaphore-wait go-sema)
|
||||
(let* ([h (connect)]
|
||||
[l (retrieve-active-assignments h)])
|
||||
(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)
|
||||
|
|
@ -255,6 +268,12 @@
|
|||
(super-new [label manage-dialog-name]
|
||||
[alignment '(left center)])
|
||||
|
||||
(define EXTRA-FIELDS
|
||||
(let ([ef #f])
|
||||
(lambda ()
|
||||
(unless ef (set! ef (retrieve-extra-fields (connect))))
|
||||
ef)))
|
||||
|
||||
(define status
|
||||
(new message%
|
||||
[label (format "Manage ~a handin account at ~a." handin-name server)]
|
||||
|
|
@ -264,7 +283,7 @@
|
|||
(define tabs
|
||||
(new tab-panel%
|
||||
[parent this]
|
||||
[choices '("New User" "Change Password" "Uninstall")]
|
||||
[choices '("New User" "Change Info" "Uninstall")]
|
||||
[callback
|
||||
(lambda (tp e)
|
||||
(send single active-child
|
||||
|
|
@ -288,61 +307,86 @@
|
|||
[style '(single password)]
|
||||
[stretchable-width #t]))
|
||||
|
||||
(define (non-empty? t)
|
||||
(not (string=? "" (send t get-value))))
|
||||
(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 (activate-change)
|
||||
(define an-extra-non-empty? (ormap non-empty? change-extra-fields))
|
||||
(send retrieve-old-info-button enable
|
||||
(non-empty? old-username old-passwd))
|
||||
(send change-button enable
|
||||
(and (non-empty? old-username)
|
||||
(non-empty? old-passwd)
|
||||
(non-empty? new-passwd)
|
||||
(non-empty? confirm-passwd))))
|
||||
(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 (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 old-passwd
|
||||
(mk-passwd "Old Password:" old-user-box activate-change))
|
||||
(define change-extra-fields
|
||||
(map (lambda (f)
|
||||
(mk-txt (format "~a:" (car f)) old-user-box activate-change))
|
||||
(EXTRA-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)))))
|
||||
|
||||
(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))))
|
||||
(and (apply non-empty? new-username add-passwd add-passwd2
|
||||
add-extra-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 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 add-extra-fields
|
||||
(map (lambda (f)
|
||||
(mk-txt (format "~a:" (car f)) new-user-box activate-new))
|
||||
(EXTRA-FIELDS)))
|
||||
;; (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 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 b e))]
|
||||
[callback (lambda (b e)
|
||||
(do-change/add #t new-username))]
|
||||
[style '(border)]))
|
||||
|
||||
(define uninstall-box (new vertical-panel%
|
||||
[parent single]
|
||||
[alignment '(center center)]))
|
||||
(define uninstall-button (new button%
|
||||
[label (format "Uninstall ~a" handin-name)]
|
||||
[label (format "Uninstall ~a Handin" handin-name)]
|
||||
[parent uninstall-box]
|
||||
[callback
|
||||
(lambda (b e)
|
||||
|
|
@ -405,42 +449,74 @@
|
|||
name size))
|
||||
(k (void))))
|
||||
|
||||
(define (do-change/add new? username b e)
|
||||
(define (do-change/add new? username)
|
||||
(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))
|
||||
(check-length username 50 "Username" k)
|
||||
(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 k)
|
||||
;; 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))
|
||||
(k (void))))
|
||||
(for-each (lambda (t f) (check-length t 100 (car f) k))
|
||||
(if new? add-extra-fields change-extra-fields)
|
||||
(EXTRA-FIELDS))
|
||||
(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-extra-fields)
|
||||
(run submit-info-change username old-passwd new-passwd
|
||||
change-extra-fields)))
|
||||
(send status set-label "Success.")
|
||||
(send cancel set-label "Close")))))))
|
||||
|
||||
(define (do-retrieve username)
|
||||
(let/ec 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))])
|
||||
(report-error "Retrieve failed." exn))])
|
||||
(remember-user (send username get-value))
|
||||
(send status set-label "Making secure connection...")
|
||||
(let-values ([(h l) (connect)])
|
||||
(let ([h (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")))))))
|
||||
(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-each (lambda (f val) (send f set-value val))
|
||||
change-extra-fields vals)
|
||||
(activate-change)))))))))
|
||||
|
||||
(send new-user-box show #f)
|
||||
(send old-user-box show #f)
|
||||
|
|
@ -489,6 +565,14 @@
|
|||
(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 read-from-file stream)
|
||||
(read-editor-global-footer stream)))
|
||||
|
||||
(add-test-suite-extension
|
||||
"Handin"
|
||||
handin-icon
|
||||
|
|
@ -529,15 +613,20 @@
|
|||
(super help-menu:after-about menu))
|
||||
|
||||
(define button
|
||||
(new 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])))]
|
||||
(new handin-frame%
|
||||
[parent this]
|
||||
[content content]
|
||||
[open-drscheme-window
|
||||
drscheme:unit:open-drscheme-window])))]
|
||||
[style '(deleted)]))
|
||||
|
||||
(send (get-button-panel) change-children
|
||||
(lambda (l) (cons button l)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -20,9 +20,10 @@ toolbar. Clicking the "Handin" button allows the student to type a
|
|||
password and upload the current content of the definitions and
|
||||
interactions window to the course instructor's server. The "File" menu
|
||||
is also extended with a "Manage..." menu item for managing a handin
|
||||
account (i.e., changing the password, or creating a new account if the
|
||||
instructor configures the server to allow new accounts). Students can
|
||||
submit joint work by submitting with a concatenation of usernames.
|
||||
account (i.e., changing the password and other information, or
|
||||
creating a new account if the instructor configures the server to
|
||||
allow new accounts). Students can submit joint work by submitting with
|
||||
a concatenation of usernames separated by a "+".
|
||||
|
||||
On the instructor's side, the handin server can be configured to check
|
||||
the student's submission before accepting it.
|
||||
|
|
@ -197,11 +198,13 @@ sub-directories:
|
|||
"BACKUP-1/handin.scm", etc.; the default is 9
|
||||
|
||||
'user-regexp : a regular expression that is used to validate
|
||||
usernames; young students often choose exotic usernames that
|
||||
are impossible to remember, and forget capitalization, so the
|
||||
default is fairly strict: #rx"^[a-z][a-z0-9]+$"; a "+" is
|
||||
always disallowed in a username, since it is used in a
|
||||
submission username to specify joint work
|
||||
usernames; alternatively, this can be #f meaning no
|
||||
restriction, or a list of permitted strings. Young students
|
||||
often choose exotic usernames that are impossible to
|
||||
remember, and forget capitalization, so the default is fairly
|
||||
strict: #rx"^[a-z][a-z0-9]+$"; a "+" is always disallowed in
|
||||
a username, since it is used in a submission username to
|
||||
specify joint work
|
||||
|
||||
'user-desc : a plain-words description of the acceptable
|
||||
username format (according to user-regexp above); #f stands
|
||||
|
|
@ -214,29 +217,13 @@ sub-directories:
|
|||
using a case-insensitive filesystem, since usernames are used
|
||||
as directory names)
|
||||
|
||||
'id-regexp : a regular expression that is used to validate a
|
||||
"free form" user id (possibly a student id) for a created
|
||||
account; the default is #rx"^.*$"
|
||||
|
||||
'id-desc : a plain-words description of the acceptable id format
|
||||
(according to id-regexp above), eg, "Utah ID Number with
|
||||
exactly nine digits"; the default is #f indicating no
|
||||
description
|
||||
|
||||
'email-regexp : a regular expression that is used to validate
|
||||
emails, the #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
|
||||
default can be changed to "" if you don't care about emails,
|
||||
or can be further restricted, for example requiring a
|
||||
"@cs.utah.edu" suffix
|
||||
|
||||
'email-desc : a plain-words description of the acceptable email
|
||||
format (according to email-regexp above), eg, "Utah CS email
|
||||
address"; #f stands for no description; the default is "a
|
||||
valid email address"
|
||||
|
||||
'allow-new-users : a boolean indicating whether to allow
|
||||
new-user requests from a client tool; the default is #f
|
||||
|
||||
'allow-change-info : a boolean indicating whether to allow
|
||||
changing user information from a client tool (changing
|
||||
passwords is always possible); the default is #f
|
||||
|
||||
'master-password : a string for an MD5 hash for a password that
|
||||
allows login as any user; the default is #f, which disables
|
||||
the password
|
||||
|
|
@ -249,18 +236,46 @@ sub-directories:
|
|||
add this configuration entry with the name of your new copy
|
||||
(relative to the handin server directory)
|
||||
|
||||
'extra-fields : a list that describes extra fields of (string)
|
||||
information for students; each element in this list is a list
|
||||
of three values -- the name of the field, the regexp (or #f,
|
||||
or a list of permitted string values), and a plain-words
|
||||
description of acceptable strings. The default is
|
||||
|
||||
'(("Full Name" #f #f)
|
||||
("ID#" #f #f)
|
||||
("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
|
||||
"a valid email address"))
|
||||
|
||||
You can set this to a list of fields that you are interested
|
||||
in keeping, for example:
|
||||
|
||||
'(("Full Name"
|
||||
#rx"^[A-Z][a-zA-Z]+(?: [A-Z][a-zA-Z]+)+$"
|
||||
"full name, no punctuations, properly capitalized")
|
||||
("Utah ID Number"
|
||||
#rx"^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$"
|
||||
"Utah ID Number with exactly nine digits")
|
||||
("Email"
|
||||
#rx"^[^@<>\"`',]+@cs\\.utah\\.edu$"
|
||||
"A Utah CS email address"))
|
||||
|
||||
The order of these fields will be used both on the client GUI
|
||||
side and in the "users.ss" file (see below).
|
||||
|
||||
* "users.ss" (created if not present if a user is added) --- keeps
|
||||
the list of user accounts, along with the associated password
|
||||
(actually the MD5 hash of the password), full name, and free-form
|
||||
id (perhaps a student id at a university) of the account. The file
|
||||
format is
|
||||
(actually the MD5 hash of the password), and extra string fields
|
||||
as specified by the 'extra-fields configuration entry (in the same
|
||||
order). The file format is
|
||||
|
||||
((<username-sym> (<pw-md5-str> <id-str> <full-name-str> <email-str>))
|
||||
((<username-sym> (<pw-md5-str> <extra-field> ...))
|
||||
...)
|
||||
|
||||
If the 'allow-new-users configuration allows new users, the
|
||||
"users.ss" file can be updated by the server with new users. It
|
||||
can always be updated by the server to change passwords.
|
||||
For example, the default 'extra-field setting will make this:
|
||||
|
||||
((<username-sym> (<pw-md5-str> <full-name> <id> <email>))
|
||||
...)
|
||||
|
||||
Username that begin with "solution" are special. They are used by
|
||||
the HTTPS status server. Independent of the 'user-regexp and
|
||||
|
|
@ -268,6 +283,43 @@ sub-directories:
|
|||
allowed to contain characters that are illegal in Windows
|
||||
pathnames, they cannot end or begin in spaces or periods.
|
||||
|
||||
If the 'allow-new-users configuration allows new users, the
|
||||
"users.ss" file can be updated by the server with new users. It
|
||||
can always be updated by the server to change passwords.
|
||||
|
||||
If you have access to a standard Unix password file (from
|
||||
"/etc/passwd" or "/etc/shadow"), then you can construct a
|
||||
"users.ss" file that will allow users to use their normal
|
||||
passwords. To achieve this, use a list with 'unix as the first
|
||||
element and the system's encrypted password string as the second
|
||||
element. Such passwords can be used, but when users change them,
|
||||
a plain md5 hash will be used.
|
||||
|
||||
You can combine this with other fields from the password file to
|
||||
create your "users.ss", but make sure you have information that
|
||||
matches your 'extra-fields specification. For example, given this
|
||||
system file:
|
||||
|
||||
foo:wRzN1u5q2SqRD:1203:1203:Foo Moo:/home/foo:/bin/tcsh
|
||||
bar:$1$dKlU0OkJ$t63NU/eTzKz:1205:1205:Bar Z. Lie:/home/bar:/bin/bash
|
||||
|
||||
you can create a "users.ss" file as
|
||||
|
||||
((foo ((unix "wRzN1u5q2SqRD") "Foo Moo" "?"))
|
||||
(bar ((unix "$1$dKlU0OkJ$t63NU/eTzKz") "Bar Z. Lie" "?")))
|
||||
|
||||
which can be combined with this setting for 'extra-fields in your
|
||||
"config.ss":
|
||||
|
||||
...
|
||||
(extra-fields (("Full Name" #f #f)
|
||||
("TA" '("Alice" "Bob") "Your TA")))
|
||||
...
|
||||
|
||||
and you can tell your students to use their department username
|
||||
and password, and use the "Manage ..." dialog to properly set
|
||||
their TA name.
|
||||
|
||||
* "active/" --- sub-directory for active assignments. A list of
|
||||
active assignments is sent to a client tool when a student clicks
|
||||
"Handin", based on the contents of this directory. The student
|
||||
|
|
@ -343,11 +395,8 @@ sub-directories:
|
|||
subdirectory, which is preserved but hidden from the status
|
||||
interface.
|
||||
|
||||
The checker should return either a string or a list of two
|
||||
strings. A single string result, such as "handin.scm", is used to
|
||||
rename the "handin" submission file. In a list result, the first
|
||||
string names the submission, and the second string is a
|
||||
successful-handin message to report back to the student.
|
||||
The checker should return a string, such as "handin.scm", to use in
|
||||
naming the submission file.
|
||||
|
||||
* "log.ss" (created if not present, appended otherwise) --- records
|
||||
connections and actions, where each entry is of the form
|
||||
|
|
@ -529,13 +578,21 @@ The _utils.ss_ module provides utilities helpful in implementing
|
|||
handin client for any test failure. Set this parameter to true when
|
||||
testing programs that use state.
|
||||
|
||||
> (message string [styles]) - if given only a string, this string will
|
||||
be shown on the client's submission dialog; if `styles' is also
|
||||
given, it will be used as a list of styles for a `message-box'
|
||||
dialog on the client side, and the resulting value is returned as
|
||||
the result of `message'. You can use that to send warnings to the
|
||||
student and wait for confirmation.
|
||||
|
||||
> (current-run-status string-or-#f) - registers information about the
|
||||
current actions of the checker, in case the session is terminated
|
||||
due to excessive memory consumption. For example, a checker might
|
||||
set the status to indicate which instructor-supplied test was being
|
||||
executed when the session ran out of memory. This status is only
|
||||
used when per-session memory limits are supported (i.e., under
|
||||
MrEd3m or MzScheme3m with memory accounting).
|
||||
MrEd3m or MzScheme3m with memory accounting), but in both cases, a
|
||||
string value will also be passed on to `message' above.
|
||||
|
||||
> (current-value-printer proc) - a parameter that controls how values
|
||||
are printed, a procedure that expects a Scheme value and returns a
|
||||
|
|
|
|||
|
|
@ -16,8 +16,19 @@
|
|||
|
||||
(define current-session (make-parameter 0))
|
||||
|
||||
(define (write+flush port x)
|
||||
(write x port) (newline port) (flush-output port))
|
||||
(define (write+flush port . xs)
|
||||
(for-each (lambda (x) (write x port) (newline port)) xs)
|
||||
(flush-output port))
|
||||
|
||||
(define-struct alist (name l))
|
||||
(define (a-set! alist key val)
|
||||
(let ([l (alist-l alist)])
|
||||
(cond [(assq key l) => (lambda (p) (set-cdr! p val))]
|
||||
[else (set-alist-l! alist (cons (cons key val) l))])))
|
||||
(define (a-ref alist key . default)
|
||||
(cond [(assq key (alist-l alist)) => cdr]
|
||||
[(pair? default) (car default)]
|
||||
[else (error (alist-name alist) "no value for `~s'" key)]))
|
||||
|
||||
(define (LOG str . args)
|
||||
;; Assemble log into into a single string, to make
|
||||
|
|
@ -34,22 +45,25 @@
|
|||
(define (get-config which default)
|
||||
(get-preference which (lambda () default) #f "config.ss"))
|
||||
|
||||
(define PORT-NUMBER (get-config 'port-number 7979))
|
||||
(define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
|
||||
(define SESSION-TIMEOUT (get-config 'session-timeout 300))
|
||||
(define PORT-NUMBER (get-config 'port-number 7979))
|
||||
(define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
|
||||
(define SESSION-TIMEOUT (get-config 'session-timeout 300))
|
||||
(define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000))
|
||||
(define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
|
||||
(define MAX-UPLOAD (get-config 'max-upload 500000))
|
||||
(define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
|
||||
(define USER-REGEXP (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
|
||||
(define USER-DESC (get-config 'user-desc "alphanumeric string"))
|
||||
(define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
|
||||
(define MAX-UPLOAD (get-config 'max-upload 500000))
|
||||
(define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
|
||||
(define USER-REGEXP (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
|
||||
(define USER-DESC (get-config 'user-desc "alphanumeric string"))
|
||||
(define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f))
|
||||
(define ID-REGEXP (get-config 'id-regexp #rx"^.*$"))
|
||||
(define ID-DESC (get-config 'id-desc #f))
|
||||
(define EMAIL-REGEXP (get-config 'email-regexp #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"))
|
||||
(define EMAIL-DESC (get-config 'email-desc "a valid email address"))
|
||||
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
|
||||
(define MASTER-PASSWD (get-config 'master-password #f))
|
||||
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
|
||||
(define ALLOW-CHANGE-INFO? (get-config 'allow-change-info #f))
|
||||
(define MASTER-PASSWD (get-config 'master-password #f))
|
||||
(define EXTRA-FIELDS
|
||||
(get-config 'extra-fields
|
||||
'(("Full Name" #f #f)
|
||||
("ID#" #f #f)
|
||||
("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
|
||||
"a valid email address"))))
|
||||
|
||||
(define orig-custodian (current-custodian))
|
||||
|
||||
|
|
@ -178,12 +192,20 @@
|
|||
(with-output-to-file part
|
||||
(lambda () (display s))))
|
||||
|
||||
(define (accept-specific-submission users assignment r r-safe w)
|
||||
(define (accept-specific-submission data r r-safe w)
|
||||
;; Note: users are always sorted
|
||||
(define users (a-ref data 'usernames))
|
||||
(define assignments (a-ref data 'assignments))
|
||||
(define assignment (a-ref data 'assignment))
|
||||
(define dirname
|
||||
(apply string-append (car users)
|
||||
(map (lambda (u) (string-append "+" u)) (cdr users))))
|
||||
(define len (read r-safe))
|
||||
(define len #f)
|
||||
(unless (member assignment assignments)
|
||||
(error 'handin "not an active assignment: ~a" assignment))
|
||||
(LOG "assignment for ~a: ~a" users assignment)
|
||||
(write+flush w 'ok)
|
||||
(set! len (read r-safe))
|
||||
(unless (and (number? len) (integer? len) (positive? len))
|
||||
(error 'handin "bad length: ~s" len))
|
||||
(unless (len . < . MAX-UPLOAD)
|
||||
|
|
@ -218,155 +240,254 @@
|
|||
(regexp-split #rx" *[+] *" (path->string dir))))
|
||||
(directory-list))
|
||||
(make-directory dirname))
|
||||
(parameterize ([current-directory dirname])
|
||||
(parameterize ([current-directory dirname]
|
||||
[current-messenger
|
||||
(case-lambda
|
||||
[(msg) (write+flush w 'message msg)]
|
||||
[(msg styles)
|
||||
(write+flush w 'message-box msg styles)
|
||||
(read (make-limited-input-port r 50))])])
|
||||
;; Clear out old ATTEMPT, if any, and make a new one:
|
||||
(when (directory-exists? ATTEMPT-DIR)
|
||||
(delete-directory/files ATTEMPT-DIR))
|
||||
(make-directory ATTEMPT-DIR)
|
||||
(save-submission s (build-path ATTEMPT-DIR "handin"))
|
||||
(LOG "checking ~a for ~a" assignment users)
|
||||
(let ([part
|
||||
;; Result is either a string or list of strings:
|
||||
(let ([checker (build-path 'up "checker.ss")])
|
||||
(if (file-exists? checker)
|
||||
(let ([checker (path->complete-path checker)])
|
||||
(parameterize ([current-directory ATTEMPT-DIR])
|
||||
((dynamic-require checker 'checker) users s)))
|
||||
DEFAULT-FILE-NAME))])
|
||||
(let ([part (let ([checker (build-path 'up "checker.ss")])
|
||||
(if (file-exists? checker)
|
||||
(let ([checker (path->complete-path checker)])
|
||||
(parameterize ([current-directory ATTEMPT-DIR])
|
||||
((dynamic-require checker 'checker)
|
||||
users s)))
|
||||
DEFAULT-FILE-NAME))])
|
||||
(current-messenger #f) ; no messages at this stage
|
||||
(write+flush w 'confirm)
|
||||
(let ([v (read (make-limited-input-port r 50))])
|
||||
(if (eq? v 'check)
|
||||
(begin
|
||||
(LOG "saving ~a for ~a" assignment users)
|
||||
(parameterize ([current-directory ATTEMPT-DIR])
|
||||
(rename-file-or-directory "handin" (if (pair? part) (car part) part)))
|
||||
(rename-file-or-directory "handin" part))
|
||||
;; Shift successful-attempt directories so that there's
|
||||
;; no SUCCESS-0:
|
||||
(make-success-dir-available 0)
|
||||
(rename-file-or-directory ATTEMPT-DIR (success-dir 0))
|
||||
(if (pair? part)
|
||||
(write+flush w (list 'result (cadr part)))
|
||||
(write+flush w 'done)))
|
||||
(rename-file-or-directory ATTEMPT-DIR (success-dir 0)))
|
||||
(error 'handin "upload not confirmed: ~s" v))))))))
|
||||
|
||||
(define (retrieve-specific-submission data w)
|
||||
;; Note: users are always sorted
|
||||
(define users (a-ref data 'usernames))
|
||||
(define assignments (a-ref data 'assignments))
|
||||
(define assignment (a-ref data 'assignment))
|
||||
(define dirname
|
||||
(apply string-append (car users)
|
||||
(map (lambda (u) (string-append "+" u)) (cdr users))))
|
||||
(unless (member assignment assignments)
|
||||
(error 'handin "not an active assignment: ~a" assignment))
|
||||
(LOG "retrieving assignment for ~a: ~a" users assignment)
|
||||
(parameterize ([current-directory (build-path "active" assignment dirname)])
|
||||
(define file
|
||||
;; find the newest wxme file
|
||||
(let loop ([files (directory-list)] [file #f] [time #f])
|
||||
(if (null? files)
|
||||
file
|
||||
(let ([f (car files)])
|
||||
(if (and (file-exists? f)
|
||||
(equal? #"WXME" (with-input-from-file f
|
||||
(lambda () (read-bytes 4))))
|
||||
(or (not file)
|
||||
(> (file-or-directory-modify-seconds f) time)))
|
||||
(loop (cdr files) f (file-or-directory-modify-seconds f))
|
||||
(loop (cdr files) file time))))))
|
||||
(let ([len (file-size file)])
|
||||
(write+flush w len)
|
||||
(display "$" w)
|
||||
(display (with-input-from-file file (lambda () (read-bytes len))) w)
|
||||
(flush-output w))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (put-user key val)
|
||||
(define (put-user-data username data)
|
||||
;; Although we don't have to worry about trashing the
|
||||
;; prefs file, we do have to worry about a thread
|
||||
;; getting killed while it locks the pref file.
|
||||
;; Avoid the problem by using orig-custodian.
|
||||
(call-in-nested-thread
|
||||
(lambda ()
|
||||
(put-preferences (list key)
|
||||
(list val)
|
||||
(lambda (f)
|
||||
(error
|
||||
'handin
|
||||
"user database busy; please try again, and alert the adminstrator if problems persist"))
|
||||
"users.ss"))
|
||||
(put-preferences
|
||||
(list (string->symbol username)) (list data)
|
||||
(lambda (f)
|
||||
(error 'handin "user database busy; please try again, and alert the adminstrator if problems persist"))
|
||||
"users.ss"))
|
||||
orig-custodian))
|
||||
|
||||
(define (add-new-user username r-safe w)
|
||||
(thread (lambda () (sleep 5) (close-input-port r-safe)))
|
||||
(let ([full-name (read r-safe)]
|
||||
[id (read r-safe)]
|
||||
[email (read r-safe)]
|
||||
[passwd (read r-safe)])
|
||||
(unless (and (string? full-name)
|
||||
(string? id)
|
||||
(string? email)
|
||||
(string? passwd))
|
||||
(error 'handin "bad user-addition request"))
|
||||
(unless (regexp-match USER-REGEXP username)
|
||||
(error 'handin "bad username: \"~a\"~a" username
|
||||
(if USER-DESC (format "; need ~a" USER-DESC) "")))
|
||||
;; Since we're going to use the username in paths:
|
||||
(when (regexp-match #rx"[/\\:|\"<>]" username)
|
||||
(error 'handin "username must not contain one of the following: / \\ : | \" < >"))
|
||||
(when (regexp-match #rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
|
||||
(string-foldcase username))
|
||||
(error 'handin "username must not be a Windows special file name"))
|
||||
(when (regexp-match #rx"^[ .]|[ .]$" username)
|
||||
(error 'handin "username must not begin or end with a space or period"))
|
||||
(when (regexp-match #rx"^solution" username)
|
||||
(error 'handin "the username prefix \"solution\" is reserved"))
|
||||
(when (string=? "checker.ss" username)
|
||||
(error 'handin "the username \"checker.ss\" is reserved"))
|
||||
(unless (regexp-match ID-REGEXP id)
|
||||
(error 'handin "id has wrong format: ~a~a" id
|
||||
(if ID-DESC (format "; need ~a for id" ID-DESC) "")))
|
||||
(unless (regexp-match EMAIL-REGEXP email)
|
||||
(error 'handin "email has wrong format: ~a~a" email
|
||||
(if EMAIL-DESC (format "; need ~a" EMAIL-DESC) "")))
|
||||
(LOG "create user: ~a" username)
|
||||
(put-user (string->symbol username)
|
||||
(list (md5 passwd) id full-name email))
|
||||
(write+flush w 'ok)))
|
||||
(define (get-user-data username)
|
||||
(get-preference (string->symbol username) (lambda () #f) #f "users.ss"))
|
||||
(define (check-field value field-re field-name field-desc)
|
||||
(unless (cond [(or (string? field-re) (regexp? field-re))
|
||||
(regexp-match field-re value)]
|
||||
[(list? field-re) (member value field-re)]
|
||||
[(not field-re) #t]
|
||||
[else (error 'handin "bad spec: field-regexp is ~e"
|
||||
field-re)])
|
||||
(error 'handin "bad ~a: \"~a\"~a" field-name value
|
||||
(if field-desc (format "; need ~a" field-desc) ""))))
|
||||
|
||||
(define (change-user-passwd username r-safe w old-user-data)
|
||||
(let ([new-passwd (read r-safe)])
|
||||
(LOG "change passwd for ~a" username)
|
||||
(unless (string? new-passwd)
|
||||
(error 'handin "bad password-change request"))
|
||||
(put-user (string->symbol username)
|
||||
(cons (md5 new-passwd) (cdr old-user-data)))
|
||||
(write+flush w 'ok)))
|
||||
(define (add-new-user data)
|
||||
(define username (a-ref data 'username/s))
|
||||
(define passwd (a-ref data 'password))
|
||||
(define extra-fields (a-ref data 'extra-fields))
|
||||
(unless ALLOW-NEW-USERS?
|
||||
(error 'handin "new users not allowed: ~a" username))
|
||||
(check-field username USER-REGEXP "username" USER-DESC)
|
||||
;; Since we're going to use the username in paths, and + to split names:
|
||||
(when (regexp-match #rx"[+/\\:|\"<>]" username)
|
||||
(error 'handin "username must not contain one of the following: + / \\ : | \" < >"))
|
||||
(when (regexp-match
|
||||
#rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
|
||||
(string-foldcase username))
|
||||
(error 'handin "username must not be a Windows special file name"))
|
||||
(when (regexp-match #rx"^[ .]|[ .]$" username)
|
||||
(error 'handin "username must not begin or end with a space or period"))
|
||||
(when (regexp-match #rx"^solution" username)
|
||||
(error 'handin "the username prefix \"solution\" is reserved"))
|
||||
(when (string=? "checker.ss" username)
|
||||
(error 'handin "the username \"checker.ss\" is reserved"))
|
||||
(when (get-user-data username)
|
||||
(error 'handin "username already exists: `~a'" username))
|
||||
(for-each
|
||||
(lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
|
||||
extra-fields EXTRA-FIELDS)
|
||||
(wait-for-lock "+newuser+")
|
||||
(LOG "create user: ~a" username)
|
||||
(put-user-data username (cons passwd extra-fields)))
|
||||
|
||||
(define (change-user-info data)
|
||||
(define usernames (a-ref data 'usernames))
|
||||
(define user-datas (a-ref data 'user-datas))
|
||||
(define passwd (a-ref data 'new-password))
|
||||
(define extra-fields (a-ref data 'extra-fields))
|
||||
(unless (= 1 (length usernames))
|
||||
(error 'handin "cannot change a password for multiple users: ~a"
|
||||
usernames))
|
||||
;; the new data is the same as the old one for every empty string
|
||||
(let ([new-data (map (lambda (old new) (if (equal? "" new) old new))
|
||||
(car user-datas) (cons passwd extra-fields))])
|
||||
(unless (or ALLOW-CHANGE-INFO? (equal? (cdr new-data) (cdar user-datas)))
|
||||
(error 'handin "changing information not allowed: ~a" (car usernames)))
|
||||
(when (equal? new-data (car user-datas))
|
||||
(error 'handin "no fields changed: ~a" (car usernames)))
|
||||
(for-each
|
||||
(lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
|
||||
(cdr new-data) EXTRA-FIELDS)
|
||||
(LOG "change info for ~a ~s -> ~s" (car usernames) new-data (car user-datas))
|
||||
(put-user-data (car usernames) new-data)))
|
||||
|
||||
(define (get-user-info data)
|
||||
(define usernames (a-ref data 'usernames))
|
||||
(unless (= 1 (length usernames))
|
||||
(error 'handin "cannot get user-info for multiple users: ~a" usernames))
|
||||
(cdar (a-ref data 'user-datas)))
|
||||
|
||||
(define crypt
|
||||
(let ([c #f] [sema (make-semaphore 1)])
|
||||
;; use only when needed so it doesn't blow up on non-unix platforms
|
||||
(lambda (passwd salt)
|
||||
(unless c (set! c (dynamic-require '(lib "crypt.ss" "ffi") 'crypt)))
|
||||
;; crypt is not reentrant
|
||||
(call-with-semaphore sema
|
||||
(lambda () (bytes->string/utf-8 (c passwd salt)))))))
|
||||
(define (has-password? raw md5 passwords)
|
||||
(define (good? passwd)
|
||||
(cond [(string? passwd) (equal? md5 passwd)]
|
||||
[(and (list? passwd) (= 2 (length passwd))
|
||||
(eq? 'unix (car passwd)) (string? (cadr passwd))
|
||||
;; find the salt part
|
||||
(regexp-match #rx"^([$][^$]+[$][^$]+[$]|..)" (cadr passwd)))
|
||||
=> (lambda (m)
|
||||
(equal? (crypt raw (car m)) (cadr passwd)))]
|
||||
[else (LOG "ERROR: bad password in user database: ~s" passwd)
|
||||
;; do not show the bad password...
|
||||
(error 'handin "bad password in user database")]))
|
||||
(or (member md5 passwords) ; very cheap search first
|
||||
(ormap good? passwords)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (accept-submission-or-update active-assignments r r-safe w)
|
||||
(write+flush w active-assignments)
|
||||
;; Get usernames and password:
|
||||
(let* ([user-string
|
||||
(let ([s (read r-safe)])
|
||||
(and (string? s)
|
||||
(if USERNAME-CASE-SENSITIVE?
|
||||
s
|
||||
(string-foldcase s))))]
|
||||
[usernames
|
||||
;; Username lists must always be sorted
|
||||
(if user-string
|
||||
(quicksort (regexp-split #rx" *[+] *" user-string) string<?)
|
||||
'())]
|
||||
[user-datas (map (lambda (u)
|
||||
(get-preference (string->symbol u)
|
||||
(lambda () #f) #f "users.ss"))
|
||||
usernames)]
|
||||
[passwd (read r-safe)])
|
||||
(cond
|
||||
[(eq? passwd 'create)
|
||||
(wait-for-lock "+newuser+")
|
||||
(unless ALLOW-NEW-USERS?
|
||||
(error 'handin "new users not allowed: ~a" user-string))
|
||||
(unless (= 1 (length usernames))
|
||||
(error 'handin "username must not contain a \"+\": ~a" user-string))
|
||||
;; we now know that there is a single username, and (car usernames) is
|
||||
;; the same at user-string
|
||||
(when (car user-datas)
|
||||
(error 'handin "username already exists: `~a'" user-string))
|
||||
(add-new-user user-string r-safe w)]
|
||||
[(and (pair? user-datas)
|
||||
(not (memq #f user-datas))
|
||||
(string? passwd)
|
||||
(let ([pw (md5 passwd)])
|
||||
(ormap (lambda (p) (equal? p pw))
|
||||
(cons MASTER-PASSWD (map car user-datas)))))
|
||||
(LOG "login: ~a" usernames)
|
||||
(let ([assignment (read r-safe)])
|
||||
(LOG "assignment for ~a: ~a" usernames assignment)
|
||||
(if (eq? assignment 'change)
|
||||
(if (= 1 (length usernames))
|
||||
(change-user-passwd (car usernames) r-safe w (car user-datas))
|
||||
(error 'handin "cannot change a password on a joint login"))
|
||||
(if (member assignment active-assignments)
|
||||
(begin
|
||||
(write+flush w 'ok)
|
||||
(accept-specific-submission usernames assignment r r-safe w))
|
||||
(error 'handin "not an active assignment: ~a" assignment))))]
|
||||
[else
|
||||
(LOG "failed login: ~a" user-string)
|
||||
(error 'handin "bad username or password for ~a" user-string)])))
|
||||
(define (handle-connection r r-safe w)
|
||||
(define msg #f)
|
||||
(define active-assignments (assignment-list))
|
||||
(define data
|
||||
(make-alist 'protocol-data `((assignments . ,active-assignments))))
|
||||
(define (perror fmt . args) (apply error 'handin-protocol fmt args))
|
||||
(let loop ()
|
||||
(set! msg (read r-safe))
|
||||
(case msg
|
||||
;; ----------------------------------------
|
||||
;; getting information from the client
|
||||
[(set)
|
||||
(let* ([key (read r-safe)] [val (read r-safe)])
|
||||
(unless (symbol? key) (perror "bad key value: ~e" key))
|
||||
(unless (if (eq? 'extra-fields key)
|
||||
(and (list? val)
|
||||
(- (length val) (length EXTRA-FIELDS))
|
||||
(andmap string? val))
|
||||
(string? val))
|
||||
(perror "bad value for set: ~e" val))
|
||||
(when (a-ref data key #f) (perror "multiple values for ~e" key))
|
||||
(case key
|
||||
[(username/s)
|
||||
(when USERNAME-CASE-SENSITIVE? (set! val (string-foldcase val)))
|
||||
(let ([usernames
|
||||
;; Username lists must always be sorted, and never empty
|
||||
;; (regexp-split will not return an empty list)
|
||||
(quicksort (regexp-split #rx" *[+] *" val) string<?)])
|
||||
(a-set! data 'usernames usernames)
|
||||
(a-set! data 'user-datas (map get-user-data usernames)))]
|
||||
[(password new-password)
|
||||
;; empty passwords are left empty for change-user-info to re-use
|
||||
;; an existing password value
|
||||
(when (eq? key 'password) (a-set! data 'raw-password val))
|
||||
(unless (equal? "" val) (set! val (md5 val)))]
|
||||
[(usernames user-datas raw-password assignments)
|
||||
;; forbid setting these directly
|
||||
(perror "bad key for `set': ~e" key)])
|
||||
(a-set! data key val))
|
||||
(loop)]
|
||||
;; ----------------------------------------
|
||||
;; sending information to the client
|
||||
[(get-active-assignments)
|
||||
(write+flush w active-assignments)
|
||||
(loop)]
|
||||
[(get-extra-fields)
|
||||
(write+flush w EXTRA-FIELDS)
|
||||
(loop)]
|
||||
;; ----------------------------------------
|
||||
;; action handlers
|
||||
;; (don't loop back except get-user-info which needs authorization)
|
||||
[(create-user) (add-new-user data)]
|
||||
[(bye) #t] ; <- general disconnection
|
||||
;; other messages require a login: valid users and a good password
|
||||
[else
|
||||
(let ([usernames (a-ref data 'usernames)]
|
||||
[user-datas (a-ref data 'user-datas)])
|
||||
(memq #f user-datas)
|
||||
(when (or (memq #f user-datas)
|
||||
(not (has-password?
|
||||
(a-ref data 'raw-password)
|
||||
(a-ref data 'password)
|
||||
(cons MASTER-PASSWD (map car user-datas)))))
|
||||
(LOG "failed login: ~a" (a-ref data 'username/s))
|
||||
(error 'handin "bad username or password for ~a"
|
||||
(a-ref data 'username/s)))
|
||||
(LOG "login: ~a" usernames))
|
||||
(case msg
|
||||
[(change-user-info) (change-user-info data)]
|
||||
[(save-submission) (accept-specific-submission data r r-safe w)]
|
||||
[(get-submission) (retrieve-specific-submission data w)]
|
||||
[(get-user-info) (write+flush w (get-user-info data)) (loop)]
|
||||
[else (perror "bad message `~a'" msg)])]))
|
||||
(write+flush w 'ok)) ; final confirmation for *all* actions
|
||||
|
||||
(define (assignment-list)
|
||||
(quicksort (map path->string (directory-list "active")) string<?))
|
||||
|
|
@ -466,7 +587,7 @@
|
|||
(with-watcher
|
||||
w
|
||||
(lambda (kill-watcher)
|
||||
(let ([r-safe (make-limited-input-port r 1024)])
|
||||
(let ([r-safe (make-limited-input-port r 2048)])
|
||||
(write+flush w 'handin)
|
||||
;; Check protocol:
|
||||
(with-handlers ([exn:fail?
|
||||
|
|
@ -479,11 +600,11 @@
|
|||
(write+flush w msg)
|
||||
;; see note on close-output-port below
|
||||
(close-output-port w)))])
|
||||
(let ([protocol (read r-safe)])
|
||||
(if (eq? protocol 'original)
|
||||
(write+flush w 'original)
|
||||
(let ([protocol (read r-safe)])
|
||||
(if (eq? protocol 'ver1)
|
||||
(write+flush w 'ver1)
|
||||
(error 'handin "unknown protocol: ~s" protocol)))
|
||||
(accept-submission-or-update (assignment-list) r r-safe w)
|
||||
(handle-connection r r-safe w)
|
||||
(LOG "normal exit")
|
||||
(kill-watcher)
|
||||
;; This close-output-port should not be necessary, and it's
|
||||
|
|
|
|||
|
|
@ -3,9 +3,13 @@
|
|||
|
||||
(define (current-run-status s)
|
||||
(let ([b (current-run-status-box)])
|
||||
(when b
|
||||
(set-box! b s))))
|
||||
(when b (set-box! b s) (message s))))
|
||||
|
||||
(provide current-run-status-box
|
||||
current-run-status))
|
||||
(define current-messenger (make-parameter #f))
|
||||
(define (message . args)
|
||||
(let ([messenger (current-messenger)])
|
||||
(and messenger (apply messenger args))))
|
||||
|
||||
(provide current-run-status-box current-run-status
|
||||
current-messenger message))
|
||||
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@
|
|||
call-with-evaluator/submission
|
||||
reraise-exn-as-submission-problem
|
||||
current-run-status
|
||||
message
|
||||
current-value-printer
|
||||
|
||||
coverage-enabled
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user