From 5622f9466a381e76d7adc132c098b0cd6bf472f5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 9 Sep 2005 02:36:44 +0000 Subject: [PATCH] Lots of changes to the handin client and server, mostly being able to deal with group submission. svn: r809 --- collects/handin-client/client.ss | 4 +- collects/handin-client/tool.ss | 39 ++- collects/handin-server/doc.txt | 129 +++++--- collects/handin-server/handin-server.ss | 287 ++++++++++-------- collects/handin-server/lock.ss | 101 +++--- .../status-web-root/htdocs/index.html | 2 + collects/handin-server/utils.ss | 115 +++++-- collects/handin-server/web-status-server.ss | 19 +- 8 files changed, 425 insertions(+), 271 deletions(-) diff --git a/collects/handin-client/client.ss b/collects/handin-client/client.ss index 3c7fa3d84b..2aad50e30e 100644 --- a/collects/handin-client/client.ss +++ b/collects/handin-client/client.ss @@ -68,10 +68,10 @@ result-msg))) - (define (submit-addition h username full-name id passwd) + (define (submit-addition h username full-name id email passwd) (let ([r (handin-r h)] [w (handin-w h)]) - (fprintf w "~s create ~s ~s ~s~n" username full-name id passwd) + (fprintf w "~s create ~s ~s ~s ~s~n" username full-name id email passwd) (let ([v (read r)]) (unless (eq? v 'ok) (error 'handin-connect "update error: ~a" v))) diff --git a/collects/handin-client/tool.ss b/collects/handin-client/tool.ss index 41d28113a5..e9ec308876 100644 --- a/collects/handin-client/tool.ss +++ b/collects/handin-client/tool.ss @@ -53,7 +53,7 @@ (define handin-frame% (class dialog% - (inherit show is-shown?) + (inherit show is-shown? center) (super-new [label "Handin"]) (init-field content) @@ -138,8 +138,7 @@ (define cancel (new button% [label "Cancel"] [parent button-panel] - [callback (lambda (b e) - (do-cancel-button))])) + [callback (lambda (b e) (do-cancel-button))])) (define (do-cancel-button) (let ([go? (begin (semaphore-wait commit-lock) @@ -245,6 +244,7 @@ (init-comm) (send passwd focus) + (center) (show #t))) (define (manage-handin-account) @@ -322,14 +322,16 @@ (and (non-empty? new-username) (non-empty? full-name) (non-empty? student-id) + (non-empty? email) (non-empty? add-passwd)))) (define new-user-box (new vertical-panel% [parent single] [alignment '(center center)])) (define new-username (mk-txt "Username:" new-user-box activate-new)) (send new-username set-value (remembered-user)) - (define full-name (mk-txt "Full Name:" new-user-box activate-new)) + (define full-name (mk-txt "Full Name:" new-user-box activate-new)) (define student-id (mk-txt "ID:" new-user-box activate-new)) + (define email (mk-txt "Email:" new-user-box activate-new)) (define add-passwd (mk-passwd "Password:" new-user-box activate-new)) (define new-button (new button% [label "Add User"] @@ -416,10 +418,11 @@ "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 add-passwd 50 "Password" k)) + (check-length username 50 "Username" k) + (check-length full-name 100 "Full Name" k) + (check-length student-id 100 "ID" k) + (check-length email 100 "Email" k) + (check-length add-passwd 50 "Password" k)) (send tabs enable #f) (parameterize ([current-custodian comm-cust]) (thread @@ -432,19 +435,15 @@ (remember-user (send username get-value)) (send status set-label "Making secure connection...") (let-values ([(h l) (connect)]) + (define (run proc . fields) + (apply proc h (map (lambda (f) (send f get-value)) + fields))) (send status set-label "Updating server...") (if new? - (submit-addition - h - (send username get-value) - (send full-name get-value) - (send student-id get-value) - (send add-passwd get-value)) - (submit-password-change - h - (send username get-value) - (send old-passwd get-value) - (send new-passwd get-value)))) + (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"))))))) @@ -519,7 +518,7 @@ (define/override (file-menu:between-open-and-revert file-menu) (new menu-item% - (label (format "Manage ~a..." handin-name)) + (label (format "Manage ~a Account..." handin-name)) (parent file-menu) (callback (lambda (m e) (manage-handin-account)))) (super file-menu:between-open-and-revert file-menu)) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 3a23879e94..0b8672a54c 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -24,9 +24,7 @@ account (i.e., changing the password, or creating a new account if the instructor configures the server to allow new accounts). On the instructor's side, the handin server can be configured to check -the student's submission before accepting it. Other configuration of -the server includes setting the list of currently active assignments -(i.e., those for which handins are accepted). +the student's submission before accepting it. The handin process uses SSL, so it is effectively as secure as the server and each user's password. @@ -57,7 +55,7 @@ Quick Start for a Test Drive: 7. In your new directory, run mred -mvqM handin-server - + 8. In the "handin-client" collection, edit "info.ss" and uncomment the line (define server:port "localhost:7979") @@ -66,7 +64,7 @@ Quick Start for a Test Drive: username "tester" and password "pw". The submitted file will be .../active/test/tester/handin.scm. - + 10. Check the status of your submission by pointing a web browser at https://localhost:7980/servlets/status.ss Note the "s" in "https". Use the "tester" username and "pw" @@ -156,15 +154,15 @@ sub-directories: * "server-cert.pem" --- the server's certificate. To create a certificate and key with openssl: - openssl req -new -nodes -x509 -days 365 -out server-cert.pem - -keyout private-key.pem + openssl req -new -nodes -x509 -days 365 -out server-cert.pem + -keyout private-key.pem * "private-key.pem" --- the private key to go with "server-cert.pem". Whereas "server-cert.pem" gets distributed to students with the handin client, "private-key.pem" is kept private. * "config.ss" (optional) --- configuration options. The file format - is + is (( ) ...) @@ -197,13 +195,28 @@ sub-directories: oldest is in "BACKUP-0/handin.scm", next oldest is "BACKUP-1/handin.scm", etc.; the default is 9 - 'id-regexp : a regular expression used to validate a "free form" - user id (possibly a student id) for a created account; the + '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; the + default is fairly strict: #rx"^[a-z][a-z0-9]+$" + + 'username-case-sensitive? : a boolean flag, when #f, usernames + are normalized to lower case for all messages; defaults to #f + + '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 format for a "free form" id; the default is "anything" + '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.foo.edu" suffix + 'allow-new-users : a boolean indicating whether to allow new-user requests from a client tool; the default is #f @@ -211,13 +224,22 @@ sub-directories: allows login as any user; the default is #f, which disables the password + 'web-base-dir : if #f (the default), the built-in web server + will use the "status-web-root" in this collection for its + configuration; to have complete control over the built in + server, you can copy and edit "status-web-root" to the + directory you're running the handin server server from, and + add this configuration entry with the name of your new copy + (relative to the handin server directory). + * "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 - (( ( )) ...) + (( ( )) + ...) If the 'allow-new-users configuration allows new users, the "users.ss" file can be updated by the server with new users. It @@ -226,12 +248,12 @@ sub-directories: The username "solution" is special. It is used by the HTTPS status server. - * "active/" --- sub-directory for active assignments. A list of active - assignments is sent to a client tool when a student clicks - "Handin". The student then selects from the list. The list of - active assignments is built once by the server when it starts. - The assignments are ordered in the student's menu using `string/checker.ss" (optional) --- a module that exports a `checker' function. This function receives two - strings. The first is a username and the second is the user's - submission as a byte string. (See also `unpack-submission', etc. from - "util.ss", below.) To reject the submission, the `checker' - function can raise an exception; the exception message will be - relayed back to the student. + strings. The first is a username list and the second is the + submission as a byte string. (See also `unpack-submission', + etc. from "util.ss", below.) To reject the submission, the + `checker' function can raise an exception; the exception message + will be relayed back to the student. + + To submit an assignment as a group, students use "user1+user2" + etc. The checker function will receive a list of usernames in + this case -- this list is always sorted, so it can check that the + list of students are in a list of authorized teams. The same + syntax ("user1+user2") is used for the directory for shared + submissions; and the usernames are always sorted so the directory + name is deterinistic. The `checker' function is called with the current directory as - "active///ATTEMPT", and the submission is saved - in the file "handin". The checker function can change "handin", - and it can create additional files in this directory or the parent - directory. (Extra files in the current directory will be preserved - as it is later renamed to "SUCCESS-0", etc.) To hide generated - files from the HTTPS status web server interface, put the files in - a subdirectory, which is preserved but hidden from the status - interface. + "active///ATTEMPT", and the submission is + saved in the file "handin". The checker function can change + "handin", and it can create additional files in this directory or + the parent directory. (Extra files in the current directory will + be preserved as it is later renamed to "SUCCESS-0", etc.) To hide + generated files from the HTTPS status web server interface, put + the files in a 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 @@ -297,13 +327,15 @@ sub-directories: most recent submission for by where was returned by the checker (or the value of the `default-file-name' configuration option if there's no checker). + If the submission is from multiple users, then "" is + actually "+" etc. * "[in]active///grade" (optional) --- 's grade for , to be reported by the HTTPS status web server. * "[in]active//solution/" --- the solution to the assignment, made available by the status server to any user who - logs in. Normall, is the only file in the directory + logs in. Normally, is the only file in the directory "/solution/"; if there are multiple files in the directory, only one named "sol.scm" is made available as the solution. @@ -360,15 +392,31 @@ The _utils.ss_ module provides utilities helpful in implementing > (make-evaluator language teachpack-paths program-port) - returns a function of one argument for evaluating expressions in the - designated teaching language, one of 'beginner, 'beginner-abbr, - 'intermediate, 'intermediate-lambda, or 'advanced. The - `teachpack-paths' list contains paths to teachpacks to load in the - evaluator. The `program-port' is an input port that produces the - content of the definitions window; use `(open-input-string "")' - for an empty definitions window. + designated language, and loading teachpacks that are specified in + `teachpack-paths'. The `program-port' is an input port that + produces the content of the definitions window; use + `(open-input-string "")' for an empty definitions window. + + The `language' can be: + * a symbol indicating a built-in language (currently, only + 'mzscheme), or a teaching language -- one of 'beginner, + 'beginner-abbr, 'intermediate, 'intermediate-lambda, or 'advanced. + * a list that begins with a 'lib symbol stands for the language + defined by this (quoted) module specification. + * a list that begins with a 'begin symbol means that the code will + not be evaluated in a module context at all, it will simply be + evaluated in a new namespace. + + The `teachpack-paths' list specifies additional code to load, can be + one of: + * paths to teachpacks to load into the module. + * a list that begins with a 'begin symbol is arbitrary code that is + prefixed into the submitted program. The actual evaluation of expressions happens in a newly created - eventspace and namespace. + eventspace and namespace, and under the supervision of a strict + security guard that reading files only from PLT collections, and no + other operations. > (make-evaluator/submission language teachpack-paths bytes) - like `make-evaluator', but the definitions content is supplied as a @@ -432,6 +480,11 @@ The _utils.ss_ module provides utilities helpful in implementing used when per-session memory limits are supported (i.e., under MrEd3m or MzScheme3m with memory accounting). +> (current-value-printer proc) - a parameter that controls how values + are printed, a procedure that expects a Scheme value and returns a + string representation for it. The default value printer uses + pretty-print, with DrScheme-like settings. + > (reraise-exn-as-submission-problem thunk) - calls thunk in a context that catches exceptions and re-raises them in a form suitable as a submission error. diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 48727e3aa2..2f716a8bfc 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -6,6 +6,7 @@ (lib "file.ss") (lib "date.ss") (lib "list.ss") + (lib "string.ss") "md5.ss" "lock.ss" "web-status-server.ss" @@ -15,6 +16,10 @@ (define current-session (make-parameter 0)) + (define (ffprintf port str . args) + (apply fprintf port str args) + (flush-output port)) + (define (LOG str . args) ;; Assemble log into into a single string, to make ;; interleaved log lines unlikely: @@ -28,25 +33,22 @@ (flush-output log-port))) (define (get-config which default) - (get-preference which - (lambda () default) - #f - "config.ss")) + (get-preference which (lambda () default) #f "config.ss")) - (define PORT-NUMBER (get-config 'port-number 7979)) + (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-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 ID-REGEXP (get-config 'id-regexp #rx"^.*$")) - (define ID-DESC (get-config 'id-desc "anything")) - (define ALLOW-NEW-USERS? (get-config 'allow-new-users #f)) - (define MASTER-PASSWD (get-config 'master-password #f)) - - (define (check-id s) - (regexp-match ID-REGEXP s)) + (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 USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f)) + (define ID-REGEXP (get-config 'id-regexp #rx"^.*$")) + (define ID-DESC (get-config 'id-desc "anything")) + (define EMAIL-REGEXP (get-config 'email-regexp #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$")) + (define ALLOW-NEW-USERS? (get-config 'allow-new-users #f)) + (define MASTER-PASSWD (get-config 'master-password #f)) (define orig-custodian (current-custodian)) @@ -65,7 +67,7 @@ (define ATTEMPT-DIR "ATTEMPT") - (define (success-dir n) + (define (success-dir n) (format "SUCCESS-~a" n)) (define (make-success-dir-available n) (let ([name (success-dir n)]) @@ -80,64 +82,75 @@ (with-output-to-file part (lambda () (display s)))) - (define (accept-specific-submission user assignment r r-safe w) + (define (accept-specific-submission users assignment r r-safe w) + ;; Note: users are always sorted + (define dirname + (apply string-append (car users) + (map (lambda (u) (string-append "+" u)) (cdr users)))) + (define len (read r-safe)) + (unless (and (number? len) (integer? len) (positive? len)) + (error 'handin "bad length: ~s" len)) + (unless (len . < . MAX-UPLOAD) + (error 'handin + "max handin file size is ~s bytes, file to handin is too big (~s bytes)" + MAX-UPLOAD len)) (parameterize ([current-directory (build-path "active" assignment)]) - (unless (directory-exists? user) - (make-directory user)) - (wait-for-lock user) - (parameterize ([current-directory user]) - (let ([len (read r-safe)]) - (unless (and (number? len) - (integer? len) - (positive? len)) - (error 'handin "bad length: ~s" len)) - (unless (len . < . MAX-UPLOAD) - (error 'handin - "max handin file size is ~s bytes, file to handin is too big (~s bytes)" - MAX-UPLOAD len)) - (fprintf w "go\n") - (flush-output w) - (unless (regexp-match #rx"[$]" r-safe) - (error 'handin - "did not find start-of-content marker")) - (let ([s (read-bytes len r)]) - (unless (and (bytes? s) (= (bytes-length s) len)) - (error 'handin - "error uploading (got ~e, expected ~s bytes)" - (if (bytes? s) (bytes-length s) s) - len)) - ;; Shift successful-attempt directories so that there's - ;; no SUCCESS-0: - (make-success-dir-available 0) - ;; 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 user) - (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) - user s))) - DEFAULT-FILE-NAME))]) - (fprintf w "confirm\n") - (flush-output w) - (let ([v (read (make-limited-input-port r 50))]) - (if (eq? v 'check) - (begin - (LOG "saving ~a for ~a" assignment user) - (parameterize ([current-directory ATTEMPT-DIR]) - (rename-file-or-directory "handin" (if (pair? part) (car part) part))) - (rename-file-or-directory ATTEMPT-DIR (success-dir 0)) - (if (pair? part) - (write (list 'result (cadr part)) w) - (fprintf w "done\n")) - (flush-output w)) - (error 'handin "upload not confirmed: ~s" v))))))))) + (wait-for-lock dirname) + (when (and (pair? users) (pair? (cdr users))) + ;; two or more users -- lock each one + (for-each wait-for-lock users)) + (ffprintf w "go\n") + (unless (regexp-match #rx"[$]" r-safe) + (error 'handin "did not find start-of-content marker")) + (let ([s (read-bytes len r)]) + (unless (and (bytes? s) (= (bytes-length s) len)) + (error 'handin "error uploading (got ~e, expected ~s bytes)" + (if (bytes? s) (bytes-length s) s) len)) + ;; we have a submission, need to create a directory if needed, make + ;; sure that no users submitted work with someone else + (unless (directory-exists? dirname) + (for-each + (lambda (dir) + (for-each + (lambda (d) + (when (member d users) + (error 'handin + "bad submission: ~a has an existing submission (~a)" + d dir))) + (regexp-split #rx"[+]" (path->string dir)))) + (directory-list)) + (make-directory dirname)) + (parameterize ([current-directory dirname]) + ;; 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) + (parameterize ([current-directory ATTEMPT-DIR]) + ((dynamic-require (path->complete-path checker) 'checker) + users s)) + DEFAULT-FILE-NAME))]) + (ffprintf w "confirm\n") + (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))) + ;; 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 (list 'result (cadr part)) w) + (fprintf w "done\n")) + (flush-output w)) + (error 'handin "upload not confirmed: ~s" v)))))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -153,18 +166,23 @@ (lambda (f) (error 'handin - "user database busy; please try again, and alert the adminstrator is problems persist")) + "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)] - [passwd (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 user name: \"~a\"" username)) ;; Since we're going to use the username in paths: (when (regexp-match #rx"[/\\:]" username) (error 'handin "username must not contain a slash, backslash, or colon")) @@ -173,12 +191,15 @@ (error 'handin "username must not be a Windows special file name")) (when (string=? "solution" username) (error 'handin "the username \"solution\" is reserved")) - (unless (check-id id) + (unless (regexp-match ID-REGEXP id) (error 'handin "id has wrong format: ~a; need ~a for id" id ID-DESC)) + (unless (regexp-match EMAIL-REGEXP email) + (error 'handin "email has wrong format: ~a" email)) + (LOG "create user: ~a" username) (put-user (string->symbol username) - (list (md5 passwd) id full-name)) + (list (md5 passwd) id full-name email)) (fprintf w "ok~n"))) - + (define (change-user-passwd username r-safe w old-user-data) (let ([new-passwd (read r-safe)]) (LOG "change passwd for ~a" username) @@ -189,46 +210,60 @@ (fprintf w "ok~n"))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - + (define (accept-submission-or-update active-assignments r r-safe w) (fprintf w "~s~n" active-assignments) - ;; Get username and password: - (let ([username (read r-safe)] - [passwd (read r-safe)]) - (let ([user-data - (and (string? username) - (get-preference (string->symbol username) - (lambda () #f) - #f - "users.ss"))]) - (cond - [(eq? passwd 'create) - (when user-data - (error 'handin "username already exists: ~a" username)) - (unless ALLOW-NEW-USERS? - (error 'handin "new users not allowed: ~a" username)) - (LOG "create user: ~a" username) - (add-new-user username r-safe w)] - [(and user-data - (string? passwd) - (let ([pw (md5 passwd)]) - (or (equal? pw (car user-data)) - (equal? pw MASTER-PASSWD)))) - (LOG "login: ~a" username) - (let ([assignment (read r-safe)]) - (LOG "assignment for ~a: ~a" username assignment) - (if (eq? assignment 'change) - (change-user-passwd username r-safe w user-data) - (if (member assignment active-assignments) - (begin - (fprintf w "ok\n") - (accept-specific-submission username assignment r r-safe w)) - (error 'handin "not an active assignment: ~a" assignment))))] - [else - (LOG "failed login: ~a" username) - (error 'handin "bad username or password for ~a" username)])))) - - (define assignment-list + ;; Get usernames and password: + (let* ([user-string + (let ([s (read r-safe)]) + (and (string? s) + (if USERNAME-CASE-SENSITIVE? + s + (let ([s (string-copy s)]) (string-lowercase! s) s))))] + [usernames + ;; User name 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) + (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 + (fprintf w "ok\n") + (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 (assignment-list) (quicksort (map path->string (directory-list "active")) string void - ;; Gets a lock on `user' for the calling thread; the lock - ;; lasts until the calling thread terminates. - (define (wait-for-lock user) + ;; Gets a lock on `user' for the calling thread; the lock lasts until the + ;; calling thread terminates. If the lock was actually acquired, then on + ;; release the cleanup-thunk will be executed (unless it is #f), even if it + ;; was released when the acquiring thread crashed. + ;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception, + ;; since this will kill the lock thread which will lock down everything + (define (wait-for-lock user . cleanup-thunk) (let ([s (make-semaphore)]) - (channel-put req-ch (make-req - (thread-dead-evt (current-thread)) - user - s)) + (channel-put req-ch + (make-req (thread-dead-evt (current-thread)) user s + (and (pair? cleanup-thunk) (car cleanup-thunk)))) (semaphore-wait s))) (define req-ch (make-channel)) - - (define-struct req (thread-dead-evt - user - sema)) - (thread (lambda () - (let loop ([locks null] - [reqs null]) - (let-values ([(locks reqs) - ;; Try to satisfy lock requests: - (let loop ([reqs (reverse reqs)][locks locks][new-reqs null]) - (cond - [(null? reqs) (values locks new-reqs)] - [(assoc (req-user (car reqs)) locks) - ;; Lock not available: - (loop (cdr reqs) locks (cons (car reqs) new-reqs))] - [else - ;; Lock is available, so take it: - (let ([req (car reqs)]) - (semaphore-post (req-sema req)) - (loop (cdr reqs) (cons (cons (req-user req) req) locks) new-reqs))]))]) - (sync - (handle-evt - req-ch - (lambda (req) - (loop locks (cons req reqs)))) - ;; Release a lock whose thread is gone: - (apply choice-evt - (map (lambda (name+req) - (handle-evt - (req-thread-dead-evt (cdr name+req)) - (lambda (v) - (loop (remq name+req locks) reqs)))) - locks)) - ;; Throw away a request whose thread is gone: - (apply choice-evt - (map (lambda (req) - (handle-evt - (req-thread-dead-evt req) - (lambda (v) - (loop locks (remq req reqs))))) - reqs)))))))) + (define-struct req (thread-dead-evt user sema cleanup-thunk)) + + (thread + (lambda () + (let loop ([locks null] + [reqs null]) + (let-values ([(locks reqs) + ;; Try to satisfy lock requests: + (let loop ([reqs (reverse reqs)] + [locks locks] + [new-reqs null]) + (if (null? reqs) + (values locks new-reqs) + (let ([req (car reqs)] + [rest (cdr reqs)]) + (if (assoc (req-user req) locks) + ;; Lock not available: + (loop rest locks (cons req new-reqs)) + ;; Lock is available, so take it: + (begin (semaphore-post (req-sema req)) + (loop (cdr reqs) + (cons (cons (req-user req) req) locks) + new-reqs))))))]) + (sync + (handle-evt req-ch (lambda (req) (loop locks (cons req reqs)))) + ;; Release a lock whose thread is gone: + (apply choice-evt + (map (lambda (name+req) + (handle-evt + (req-thread-dead-evt (cdr name+req)) + (lambda (v) + ;; releasing a lock => run cleanup + (cond [(req-cleanup-thunk (cdr name+req)) + => (lambda (t) (t))]) + (loop (remq name+req locks) reqs)))) + locks)) + ;; Throw away a request whose thread is gone: + (apply choice-evt + (map (lambda (req) + (handle-evt + (req-thread-dead-evt req) + (lambda (v) (loop locks (remq req reqs))))) + reqs)))))))) diff --git a/collects/handin-server/status-web-root/htdocs/index.html b/collects/handin-server/status-web-root/htdocs/index.html index a5dc548987..6b228e97e1 100644 --- a/collects/handin-server/status-web-root/htdocs/index.html +++ b/collects/handin-server/status-web-root/htdocs/index.html @@ -2,5 +2,7 @@ Handin Status Web Server The handin status server is running. +
+You can check your submissions on this server. diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index 7de66253d2..790eb146f5 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -5,10 +5,11 @@ "run-status.ss" (prefix pc: (lib "pconvert.ss")) (lib "pretty.ss") - (lib "list.ss")) + (lib "list.ss") + (lib "string.ss")) (provide unpack-submission - + unpack-test-suite-submission is-test-suite-submission? @@ -21,6 +22,7 @@ call-with-evaluator/submission reraise-exn-as-submission-problem current-run-status + current-value-printer check-proc check-defined @@ -130,6 +132,31 @@ (super-new))) + ;; Protection --------------------------------------- + + (define ok-path-re + (regexp + (string-append + "^(?:" + (apply string-append + (cdr (apply append (map (lambda (p) (list "|" (regexp-quote p))) + (current-library-collection-paths))))) + ")(?:/|$)"))) + + (define tight-security + (make-security-guard + (current-security-guard) + (lambda (what path modes) + (when (or (memq 'write modes) + (memq 'execute modes) + (memq 'delete modes) + (not (regexp-match ok-path-re (path->string path)))) + (error what "file access denied (~a)" path))) + (lambda (what host port mode) (error what "network access denied")))) + + (define (safe-eval expr) + (parameterize ([current-security-guard tight-security]) + (eval expr))) ;; Execution ---------------------------------------- @@ -149,27 +176,55 @@ (lambda () ;; First read program and evaluate it as a module: (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) - (let ([prog-body - (parameterize ([read-case-sensitive #t] - [read-decimal-as-inexact #f]) - (let loop ([l null]) - (let ([expr (read-syntax 'program program-port)]) - (if (eof-object? expr) - (reverse l) - (loop (cons expr l))))))]) - (eval `(module m (lib ,(case language - [(beginner) "htdp-beginner.ss"] - [(beginner-abbr) "htdp-beginner-abbr.ss"] - [(intermediate) "htdp-intermediate.ss"] - [(intermediate-lambda) "htdp-intermediate-lambda.ss"] - [(advanced) "htdp-advanced.ss"]) - "lang") - ,@(map (lambda (tp) - `(,#'require (file ,tp))) - teachpacks) - ,@prog-body)) - (eval `(require m)) - (current-namespace (module->namespace 'm))) + (let* ([body + (parameterize ([read-case-sensitive #t] + [read-decimal-as-inexact #f]) + (let loop ([l null]) + (let ([expr (read-syntax 'program program-port)]) + (if (eof-object? expr) + (reverse l) + (loop (cons expr l))))))] + [body (append (if (and (pair? teachpacks) + (eq? 'begin (car teachpacks))) + (cdr teachpacks) + (map (lambda (tp) + `(,#'require + ,(if (pair? tp) + tp `(file ,tp)))) + teachpacks)) + body)] + [body + (cond + [(and (symbol? language) + (memq language '(beginner + beginner-abbr + intermediate + intermediate-lambda + advanced))) + `(module m + (lib ,(case language + [(beginner) "htdp-beginner.ss"] + [(beginner-abbr) "htdp-beginner-abbr.ss"] + [(intermediate) "htdp-intermediate.ss"] + [(intermediate-lambda) "htdp-intermediate-lambda.ss"] + [(advanced) "htdp-advanced.ss"]) + "lang") + ,@body)] + [(or (and (pair? language) (eq? 'lib (car language))) + (symbol? language)) + `(module m ,language ,@body)] + [(and (pair? language) + (eq? 'begin (car language))) + `(begin ,language ,@body)] + [else (error 'make-evaluator + "Bad language specification: ~e" + language)])]) + (safe-eval body) + (when (and (pair? body) (eq? 'module (car body)) + (pair? (cdr body)) (symbol? (cadr body))) + (let ([mod (cadr body)]) + (safe-eval `(require ,mod)) + (current-namespace (module->namespace mod))))) (channel-put result-ch 'ok)) ;; Now wait for interaction expressions: (let loop () @@ -177,7 +232,7 @@ (unless (eof-object? expr) (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) - (channel-put result-ch (cons 'val (eval expr)))) + (channel-put result-ch (cons 'val (safe-eval expr)))) (loop)))) (let loop () (channel-put result-ch '(exn . no-more-to-evaluate)) @@ -297,14 +352,14 @@ 0)))))))) (define list-abbreviation-enabled (make-parameter #f)) - + (define (value-converter v) (parameterize ([pc:booleans-as-true/false #t] [pc:abbreviate-cons-as-list (list-abbreviation-enabled)] [pc:constructor-style-printing #t]) (pc:print-convert v))) - (define (value-printer v) + (define (default-value-printer v) (parameterize ([pretty-print-show-inexactness #t] [pretty-print-.-symbol-without-bars #t] [pretty-print-exact-as-decimal #t] @@ -313,10 +368,11 @@ (let ([p (open-output-string)]) (pretty-print (value-converter v) p) (regexp-replace #rx"\n$" (get-output-string p) "")))) + (define current-value-printer (make-parameter default-value-printer)) (define (call-with-evaluator lang teachpacks program-port go) (parameterize ([error-value->string-handler (lambda (v s) - (value-printer v))] + ((current-value-printer) v))] [list-abbreviation-enabled (not (or (eq? lang 'beginner) (eq? lang 'beginner-abbr)))]) (reraise-exn-as-submission-problem @@ -324,10 +380,9 @@ (let ([e (make-evaluator lang teachpacks program-port)]) (current-run-status "executing your code") (go e)))))) - + (define (call-with-evaluator/submission lang teachpacks str go) (let-values ([(defs interacts) (unpack-submission str)]) (call-with-evaluator lang teachpacks (open-input-text-editor defs) go))) - - ) + ) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index f6508d506c..0f66000d25 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -7,12 +7,21 @@ (lib "ssl-tcp-unit.ss" "net") (lib "tcp-sig.ss" "net") (lib "tcp-unit.ss" "net") - (lib "file.ss")) + (lib "file.ss") + (lib "etc.ss")) (provide serve-status) - (define (serve-status port-no) - + (define (serve-status port-no get-config) + + (define WEB-BASE-DIR (get-config 'web-base-dir #f)) + + (define web-dir + (path->string + (if WEB-BASE-DIR + (build-path (current-directory) WEB-BASE-DIR) + (build-path (this-expression-source-directory) "status-web-root")))) + (define config `((port ,port-no) (max-waiting 40) @@ -37,10 +46,10 @@ (file-base-connection-timeout 30)) (paths (configuration-root "conf") - (host-root ,(path->string (build-path (collection-path "handin-server") "status-web-root"))) + (host-root ,web-dir) (log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss"))) (file-root "htdocs") - (servlet-root ,(path->string (build-path (collection-path "handin-server") "status-web-root"))) + (servlet-root ,web-dir) (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords")))))) (virtual-host-table)))