From 6d152fb925fe9cf501267774ffb25432c601adcf Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 6 Oct 2005 06:32:25 +0000 Subject: [PATCH] * 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 --- collects/handin-client/client.ss | 157 ++++++--- collects/handin-client/tool.ss | 333 +++++++++++++------- collects/handin-server/doc.txt | 139 +++++--- collects/handin-server/handin-server.ss | 403 +++++++++++++++--------- collects/handin-server/run-status.ss | 12 +- collects/handin-server/utils.ss | 1 + 6 files changed, 689 insertions(+), 356 deletions(-) diff --git a/collects/handin-client/client.ss b/collects/handin-client/client.ss index a48c40baca..7611a4701f 100644 --- a/collects/handin-client/client.ss +++ b/collects/handin-client/client.ss @@ -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))) + + ) diff --git a/collects/handin-client/tool.ss b/collects/handin-client/tool.ss index e00172ee0d..75620c6166 100644 --- a/collects/handin-client/tool.ss +++ b/collects/handin-client/tool.ss @@ -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))))) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index b7e5fa5536..ff9ccea974 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -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 - (( ( )) + (( ( ...)) ...) - 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 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 diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 30f54e39b0..deac197697 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -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) stringsymbol 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) stringstring (directory-list "active")) string