suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Lots of changes to the handin client and server, mostly being able to deal with

Browse Source 
group submission.

svn: r809
This commit is contained in:
Eli Barzilay 2005-09-09 02:36:44 +00:00
parent bcf8da09fe
commit 5622f9466a
8 changed files with 425 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/handin-client/client.ss
View File

@ -68,10 +68,10 @@
result-msg))) 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)] (let ([r (handin-r h)]
[w (handin-w 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)]) (let ([v (read r)])
(unless (eq? v 'ok) (unless (eq? v 'ok)
(error 'handin-connect "update error: ~a" v))) (error 'handin-connect "update error: ~a" v)))

39
collects/handin-client/tool.ss
View File

@ -53,7 +53,7 @@
(define handin-frame% (define handin-frame%
(class dialog% (class dialog%
(inherit show is-shown?) (inherit show is-shown? center)
(super-new [label "Handin"]) (super-new [label "Handin"])
(init-field content) (init-field content)
@ -138,8 +138,7 @@
(define cancel (new button% (define cancel (new button%
[label "Cancel"] [label "Cancel"]
[parent button-panel] [parent button-panel]
[callback (lambda (b e) [callback (lambda (b e) (do-cancel-button))]))
(do-cancel-button))]))
(define (do-cancel-button) (define (do-cancel-button)
(let ([go? (begin (let ([go? (begin
(semaphore-wait commit-lock) (semaphore-wait commit-lock)
@ -245,6 +244,7 @@
(init-comm) (init-comm)
(send passwd focus) (send passwd focus)
(center)
(show #t))) (show #t)))
(define (manage-handin-account) (define (manage-handin-account)
@ -322,14 +322,16 @@
(and (non-empty? new-username) (and (non-empty? new-username)
(non-empty? full-name) (non-empty? full-name)
(non-empty? student-id) (non-empty? student-id)
(non-empty? email)
(non-empty? add-passwd)))) (non-empty? add-passwd))))
(define new-user-box (new vertical-panel% (define new-user-box (new vertical-panel%
[parent single] [parent single]
[alignment '(center center)])) [alignment '(center center)]))
(define new-username (mk-txt "Username:" new-user-box activate-new)) (define new-username (mk-txt "Username:" new-user-box activate-new))
(send new-username set-value (remembered-user)) (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 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-passwd (mk-passwd "Password:" new-user-box activate-new))
(define new-button (new button% (define new-button (new button%
[label "Add User"] [label "Add User"]
@ -416,10 +418,11 @@
"The \"New\" and \"New again\" passwords are not the same.") "The \"New\" and \"New again\" passwords are not the same.")
(k (void)))) (k (void))))
(when new? (when new?
(check-length username 50 "Username" k) (check-length username 50 "Username" k)
(check-length full-name 100 "Full Name" k) (check-length full-name 100 "Full Name" k)
(check-length student-id 100 "ID" k) (check-length student-id 100 "ID" k)
(check-length add-passwd 50 "Password" k)) (check-length email 100 "Email" k)
(check-length add-passwd 50 "Password" k))
(send tabs enable #f) (send tabs enable #f)
(parameterize ([current-custodian comm-cust]) (parameterize ([current-custodian comm-cust])
(thread (thread
@ -432,19 +435,15 @@
(remember-user (send username get-value)) (remember-user (send username get-value))
(send status set-label "Making secure connection...") (send status set-label "Making secure connection...")
(let-values ([(h l) (connect)]) (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...") (send status set-label "Updating server...")
(if new? (if new?
(submit-addition (run submit-addition
h username full-name student-id email add-passwd)
(send username get-value) (run submit-password-change
(send full-name get-value) username old-passwd new-passwd)))
(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))))
(send status set-label "Success.") (send status set-label "Success.")
(send cancel set-label "Close"))))))) (send cancel set-label "Close")))))))
@ -519,7 +518,7 @@
(define/override (file-menu:between-open-and-revert file-menu) (define/override (file-menu:between-open-and-revert file-menu)
(new menu-item% (new menu-item%
(label (format "Manage ~a..." handin-name)) (label (format "Manage ~a Account..." handin-name))
(parent file-menu) (parent file-menu)
(callback (lambda (m e) (manage-handin-account)))) (callback (lambda (m e) (manage-handin-account))))
(super file-menu:between-open-and-revert file-menu)) (super file-menu:between-open-and-revert file-menu))

129
collects/handin-server/doc.txt
View File

@ -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). instructor configures the server to allow new accounts).
On the instructor's side, the handin server can be configured to check On the instructor's side, the handin server can be configured to check
the student's submission before accepting it. Other configuration of the student's submission before accepting it.
the server includes setting the list of currently active assignments
(i.e., those for which handins are accepted).
The handin process uses SSL, so it is effectively as secure as the The handin process uses SSL, so it is effectively as secure as the
server and each user's password. server and each user's password.
@ -57,7 +55,7 @@ Quick Start for a Test Drive:
7. In your new directory, run 7. In your new directory, run
mred -mvqM handin-server mred -mvqM handin-server
8. In the "handin-client" collection, edit "info.ss" and 8. In the "handin-client" collection, edit "info.ss" and
uncomment the line uncomment the line
(define server:port "localhost:7979") (define server:port "localhost:7979")
@ -66,7 +64,7 @@ Quick Start for a Test Drive:
username "tester" and password "pw". username "tester" and password "pw".
The submitted file will be .../active/test/tester/handin.scm. The submitted file will be .../active/test/tester/handin.scm.
10. Check the status of your submission by pointing a web browser at 10. Check the status of your submission by pointing a web browser at
https://localhost:7980/servlets/status.ss https://localhost:7980/servlets/status.ss
Note the "s" in "https". Use the "tester" username and "pw" 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 * "server-cert.pem" --- the server's certificate. To create a
certificate and key with openssl: certificate and key with openssl:
openssl req -new -nodes -x509 -days 365 -out server-cert.pem openssl req -new -nodes -x509 -days 365 -out server-cert.pem
-keyout private-key.pem -keyout private-key.pem
* "private-key.pem" --- the private key to go with "server-cert.pem". * "private-key.pem" --- the private key to go with "server-cert.pem".
Whereas "server-cert.pem" gets distributed to students with the Whereas "server-cert.pem" gets distributed to students with the
handin client, "private-key.pem" is kept private. handin client, "private-key.pem" is kept private.
* "config.ss" (optional) --- configuration options. The file format * "config.ss" (optional) --- configuration options. The file format
is is
((<key> <val>) ...) ((<key> <val>) ...)
@ -197,13 +195,28 @@ sub-directories:
oldest is in "BACKUP-0/handin.scm", next oldest is oldest is in "BACKUP-0/handin.scm", next oldest is
"BACKUP-1/handin.scm", etc.; the default is 9 "BACKUP-1/handin.scm", etc.; the default is 9
'id-regexp : a regular expression used to validate a "free form" 'user-regexp : a regular expression that is used to validate
user id (possibly a student id) for a created account; the 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"^.*$" default is #rx"^.*$"
'id-desc : a plain-words description of the acceptable format 'id-desc : a plain-words description of the acceptable format
for a "free form" id; the default is "anything" 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 'allow-new-users : a boolean indicating whether to allow
new-user requests from a client tool; the default is #f 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 allows login as any user; the default is #f, which disables
the password 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 * "users.ss" (created if not present if a user is added) --- keeps
the list of user accounts, along with the associated password the list of user accounts, along with the associated password
(actually the MD5 hash of the password), full name, and free-form (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 id (perhaps a student id at a university) of the account. The file
format is format is
((<username-sym> (<pw-md5-str> <full-name-str> <id-str>)) ...) ((<username-sym> (<pw-md5-str> <id-str> <full-name-str> <email-str>))
...)
If the 'allow-new-users configuration allows new users, the If the 'allow-new-users configuration allows new users, the
"users.ss" file can be updated by the server with new users. It "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 The username "solution" is special. It is used by the HTTPS status
server. server.
* "active/" --- sub-directory for active assignments. A list of active * "active/" --- sub-directory for active assignments. A list of
assignments is sent to a client tool when a student clicks active assignments is sent to a client tool when a student clicks
"Handin". The student then selects from the list. The list of "Handin", based on the contents of this directory. The student
active assignments is built once by the server when it starts. then selects from the list. The assignments are ordered in the
The assignments are ordered in the student's menu using `string<?', student's menu using `string<?', and the first assignment is the
and the first assignment is the default selection. default selection.
Within each directory, the student id is used for a sub-directory Within each directory, the student id is used for a sub-directory
name. Within each student sub-directory are directories for handin name. Within each student sub-directory are directories for handin
@ -261,21 +283,29 @@ sub-directories:
* "active/<assignment>/checker.ss" (optional) --- a module that * "active/<assignment>/checker.ss" (optional) --- a module that
exports a `checker' function. This function receives two exports a `checker' function. This function receives two
strings. The first is a username and the second is the user's strings. The first is a username list and the second is the
submission as a byte string. (See also `unpack-submission', etc. from submission as a byte string. (See also `unpack-submission',
"util.ss", below.) To reject the submission, the `checker' etc. from "util.ss", below.) To reject the submission, the
function can raise an exception; the exception message will be `checker' function can raise an exception; the exception message
relayed back to the student. 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 The `checker' function is called with the current directory as
"active/<assignment>/<user>/ATTEMPT", and the submission is saved "active/<assignment>/<user/s>/ATTEMPT", and the submission is
in the file "handin". The checker function can change "handin", saved in the file "handin". The checker function can change
and it can create additional files in this directory or the parent "handin", and it can create additional files in this directory or
directory. (Extra files in the current directory will be preserved the parent directory. (Extra files in the current directory will
as it is later renamed to "SUCCESS-0", etc.) To hide generated be preserved as it is later renamed to "SUCCESS-0", etc.) To hide
files from the HTTPS status web server interface, put the files in generated files from the HTTPS status web server interface, put
a subdirectory, which is preserved but hidden from the status the files in a subdirectory, which is preserved but hidden from
interface. the status interface.
The checker should return either a string or a list of two The checker should return either a string or a list of two
strings. A single string result, such as "handin.scm", is used to strings. A single string result, such as "handin.scm", is used to
@ -297,13 +327,15 @@ sub-directories:
most recent submission for <assignment> by <user> where <filename> most recent submission for <assignment> by <user> where <filename>
was returned by the checker (or the value of the was returned by the checker (or the value of the
`default-file-name' configuration option if there's no checker). `default-file-name' configuration option if there's no checker).
If the submission is from multiple users, then "<user>" is
actually "<user1>+<user2>" etc.
* "[in]active/<assignment>/<user>/grade" (optional) --- <user>'s grade * "[in]active/<assignment>/<user>/grade" (optional) --- <user>'s grade
for <assignment>, to be reported by the HTTPS status web server. for <assignment>, to be reported by the HTTPS status web server.
* "[in]active/<assignment>/solution/<file>" --- the solution to the * "[in]active/<assignment>/solution/<file>" --- the solution to the
assignment, made available by the status server to any user who assignment, made available by the status server to any user who
logs in. Normall, <file> is the only file in the directory logs in. Normally, <file> is the only file in the directory
"<assignment>/solution/"; if there are multiple files in the "<assignment>/solution/"; if there are multiple files in the
directory, only one named "<assignment>sol.scm" is made available directory, only one named "<assignment>sol.scm" is made available
as the solution. 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 > (make-evaluator language teachpack-paths program-port) - returns a
function of one argument for evaluating expressions in the function of one argument for evaluating expressions in the
designated teaching language, one of 'beginner, 'beginner-abbr, designated language, and loading teachpacks that are specified in
'intermediate, 'intermediate-lambda, or 'advanced. The `teachpack-paths'. The `program-port' is an input port that
`teachpack-paths' list contains paths to teachpacks to load in the produces the content of the definitions window; use
evaluator. The `program-port' is an input port that produces the `(open-input-string "")' for an empty definitions window.
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 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/submission language teachpack-paths bytes) - like
`make-evaluator', but the definitions content is supplied as a `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 used when per-session memory limits are supported (i.e., under
MrEd3m or MzScheme3m with memory accounting). 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 > (reraise-exn-as-submission-problem thunk) - calls thunk in a context
that catches exceptions and re-raises them in a form suitable as a that catches exceptions and re-raises them in a form suitable as a
submission error. submission error.

287
collects/handin-server/handin-server.ss
View File

@ -6,6 +6,7 @@
(lib "file.ss") (lib "file.ss")
(lib "date.ss") (lib "date.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss")
"md5.ss" "md5.ss"
"lock.ss" "lock.ss"
"web-status-server.ss" "web-status-server.ss"
@ -15,6 +16,10 @@
(define current-session (make-parameter 0)) (define current-session (make-parameter 0))
(define (ffprintf port str . args)
(apply fprintf port str args)
(flush-output port))
(define (LOG str . args) (define (LOG str . args)
;; Assemble log into into a single string, to make ;; Assemble log into into a single string, to make
;; interleaved log lines unlikely: ;; interleaved log lines unlikely:
@ -28,25 +33,22 @@
(flush-output log-port))) (flush-output log-port)))
(define (get-config which default) (define (get-config which default)
(get-preference which (get-preference which (lambda () default) #f "config.ss"))
(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 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 SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000))
(define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm")) (define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
(define MAX-UPLOAD (get-config 'max-upload 500000)) (define MAX-UPLOAD (get-config 'max-upload 500000))
(define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9)) (define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
(define ID-REGEXP (get-config 'id-regexp #rx"^.*$")) (define USER-REGEXP (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
(define ID-DESC (get-config 'id-desc "anything")) (define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f))
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f)) (define ID-REGEXP (get-config 'id-regexp #rx"^.*$"))
(define MASTER-PASSWD (get-config 'master-password #f)) (define ID-DESC (get-config 'id-desc "anything"))
(define EMAIL-REGEXP (get-config 'email-regexp #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"))
(define (check-id s) (define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
(regexp-match ID-REGEXP s)) (define MASTER-PASSWD (get-config 'master-password #f))
(define orig-custodian (current-custodian)) (define orig-custodian (current-custodian))
@ -65,7 +67,7 @@
(define ATTEMPT-DIR "ATTEMPT") (define ATTEMPT-DIR "ATTEMPT")
(define (success-dir n) (define (success-dir n)
(format "SUCCESS-~a" n)) (format "SUCCESS-~a" n))
(define (make-success-dir-available n) (define (make-success-dir-available n)
(let ([name (success-dir n)]) (let ([name (success-dir n)])
@ -80,64 +82,75 @@
(with-output-to-file part (with-output-to-file part
(lambda () (display s)))) (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)]) (parameterize ([current-directory (build-path "active" assignment)])
(unless (directory-exists? user) (wait-for-lock dirname)
(make-directory user)) (when (and (pair? users) (pair? (cdr users)))
(wait-for-lock user) ;; two or more users -- lock each one
(parameterize ([current-directory user]) (for-each wait-for-lock users))
(let ([len (read r-safe)]) (ffprintf w "go\n")
(unless (and (number? len) (unless (regexp-match #rx"[$]" r-safe)
(integer? len) (error 'handin "did not find start-of-content marker"))
(positive? len)) (let ([s (read-bytes len r)])
(error 'handin "bad length: ~s" len)) (unless (and (bytes? s) (= (bytes-length s) len))
(unless (len . < . MAX-UPLOAD) (error 'handin "error uploading (got ~e, expected ~s bytes)"
(error 'handin (if (bytes? s) (bytes-length s) s) len))
"max handin file size is ~s bytes, file to handin is too big (~s bytes)" ;; we have a submission, need to create a directory if needed, make
MAX-UPLOAD len)) ;; sure that no users submitted work with someone else
(fprintf w "go\n") (unless (directory-exists? dirname)
(flush-output w) (for-each
(unless (regexp-match #rx"[$]" r-safe) (lambda (dir)
(error 'handin (for-each
"did not find start-of-content marker")) (lambda (d)
(let ([s (read-bytes len r)]) (when (member d users)
(unless (and (bytes? s) (= (bytes-length s) len)) (error 'handin
(error 'handin "bad submission: ~a has an existing submission (~a)"
"error uploading (got ~e, expected ~s bytes)" d dir)))
(if (bytes? s) (bytes-length s) s) (regexp-split #rx"[+]" (path->string dir))))
len)) (directory-list))
;; Shift successful-attempt directories so that there's (make-directory dirname))
;; no SUCCESS-0: (parameterize ([current-directory dirname])
(make-success-dir-available 0) ;; Clear out old ATTEMPT, if any, and make a new one:
;; Clear out old ATTEMPT, if any, and make a new one: (when (directory-exists? ATTEMPT-DIR)
(when (directory-exists? ATTEMPT-DIR) (delete-directory/files ATTEMPT-DIR))
(delete-directory/files ATTEMPT-DIR)) (make-directory ATTEMPT-DIR)
(make-directory ATTEMPT-DIR) (save-submission s (build-path ATTEMPT-DIR "handin"))
(save-submission s (build-path ATTEMPT-DIR "handin")) (LOG "checking ~a for ~a" assignment users)
(LOG "checking ~a for ~a" assignment user) (let ([part
(let ([part ;; Result is either a string or list of strings:
;; Result is either a string or list of strings: (let ([checker (build-path 'up "checker.ss")])
(let ([checker (build-path 'up "checker.ss")]) (if (file-exists? checker)
(if (file-exists? checker) (parameterize ([current-directory ATTEMPT-DIR])
(let ([checker (path->complete-path checker)]) ((dynamic-require (path->complete-path checker) 'checker)
(parameterize ([current-directory ATTEMPT-DIR]) users s))
((dynamic-require checker 'checker) DEFAULT-FILE-NAME))])
user s))) (ffprintf w "confirm\n")
DEFAULT-FILE-NAME))]) (let ([v (read (make-limited-input-port r 50))])
(fprintf w "confirm\n") (if (eq? v 'check)
(flush-output w) (begin
(let ([v (read (make-limited-input-port r 50))]) (LOG "saving ~a for ~a" assignment users)
(if (eq? v 'check) (parameterize ([current-directory ATTEMPT-DIR])
(begin (rename-file-or-directory "handin" (if (pair? part) (car part) part)))
(LOG "saving ~a for ~a" assignment user) ;; Shift successful-attempt directories so that there's
(parameterize ([current-directory ATTEMPT-DIR]) ;; no SUCCESS-0:
(rename-file-or-directory "handin" (if (pair? part) (car part) part))) (make-success-dir-available 0)
(rename-file-or-directory ATTEMPT-DIR (success-dir 0)) (rename-file-or-directory ATTEMPT-DIR (success-dir 0))
(if (pair? part) (if (pair? part)
(write (list 'result (cadr part)) w) (write (list 'result (cadr part)) w)
(fprintf w "done\n")) (fprintf w "done\n"))
(flush-output w)) (flush-output w))
(error 'handin "upload not confirmed: ~s" v))))))))) (error 'handin "upload not confirmed: ~s" v))))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -153,18 +166,23 @@
(lambda (f) (lambda (f)
(error (error
'handin '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")) "users.ss"))
orig-custodian)) orig-custodian))
(define (add-new-user username r-safe w) (define (add-new-user username r-safe w)
(thread (lambda () (sleep 5) (close-input-port r-safe)))
(let ([full-name (read r-safe)] (let ([full-name (read r-safe)]
[id (read r-safe)] [id (read r-safe)]
[passwd (read r-safe)]) [email (read r-safe)]
[passwd (read r-safe)])
(unless (and (string? full-name) (unless (and (string? full-name)
(string? id) (string? id)
(string? email)
(string? passwd)) (string? passwd))
(error 'handin "bad user-addition request")) (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: ;; Since we're going to use the username in paths:
(when (regexp-match #rx"[/\\:]" username) (when (regexp-match #rx"[/\\:]" username)
(error 'handin "username must not contain a slash, backslash, or colon")) (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")) (error 'handin "username must not be a Windows special file name"))
(when (string=? "solution" username) (when (string=? "solution" username)
(error 'handin "the username \"solution\" is reserved")) (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)) (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) (put-user (string->symbol username)
(list (md5 passwd) id full-name)) (list (md5 passwd) id full-name email))
(fprintf w "ok~n"))) (fprintf w "ok~n")))
(define (change-user-passwd username r-safe w old-user-data) (define (change-user-passwd username r-safe w old-user-data)
(let ([new-passwd (read r-safe)]) (let ([new-passwd (read r-safe)])
(LOG "change passwd for ~a" username) (LOG "change passwd for ~a" username)
@ -189,46 +210,60 @@
(fprintf w "ok~n"))) (fprintf w "ok~n")))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (accept-submission-or-update active-assignments r r-safe w) (define (accept-submission-or-update active-assignments r r-safe w)
(fprintf w "~s~n" active-assignments) (fprintf w "~s~n" active-assignments)
;; Get username and password: ;; Get usernames and password:
(let ([username (read r-safe)] (let* ([user-string
[passwd (read r-safe)]) (let ([s (read r-safe)])
(let ([user-data (and (string? s)
(and (string? username) (if USERNAME-CASE-SENSITIVE?
(get-preference (string->symbol username) s
(lambda () #f) (let ([s (string-copy s)]) (string-lowercase! s) s))))]
#f [usernames
"users.ss"))]) ;; User name lists must always be sorted
(cond (if user-string
[(eq? passwd 'create) (quicksort (regexp-split #rx" *[+] *" user-string) string<?)
(when user-data '())]
(error 'handin "username already exists: ~a" username)) [user-datas (map (lambda (u)
(unless ALLOW-NEW-USERS? (get-preference (string->symbol u)
(error 'handin "new users not allowed: ~a" username)) (lambda () #f) #f "users.ss"))
(LOG "create user: ~a" username) usernames)]
(add-new-user username r-safe w)] [passwd (read r-safe)])
[(and user-data (cond
(string? passwd) [(eq? passwd 'create)
(let ([pw (md5 passwd)]) (unless ALLOW-NEW-USERS?
(or (equal? pw (car user-data)) (error 'handin "new users not allowed: ~a" user-string))
(equal? pw MASTER-PASSWD)))) (unless (= 1 (length usernames))
(LOG "login: ~a" username) (error 'handin "username must not contain a \"+\": ~a" user-string))
(let ([assignment (read r-safe)]) ;; we now know that there is a single username, and (car usernames) is
(LOG "assignment for ~a: ~a" username assignment) ;; the same at user-string
(if (eq? assignment 'change) (when (car user-datas)
(change-user-passwd username r-safe w user-data) (error 'handin "username already exists: `~a'" user-string))
(if (member assignment active-assignments) (add-new-user user-string r-safe w)]
(begin [(and (pair? user-datas)
(fprintf w "ok\n") (not (memq #f user-datas))
(accept-specific-submission username assignment r r-safe w)) (string? passwd)
(error 'handin "not an active assignment: ~a" assignment))))] (let ([pw (md5 passwd)])
[else (ormap (lambda (p) (equal? p pw))
(LOG "failed login: ~a" username) (cons MASTER-PASSWD (map car user-datas)))))
(error 'handin "bad username or password for ~a" username)])))) (LOG "login: ~a" usernames)
(let ([assignment (read r-safe)])
(define assignment-list (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<?)) (quicksort (map path->string (directory-list "active")) string<?))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -289,14 +324,14 @@
(channel-get session-channel)) (channel-get session-channel))
;; Watcher didn't work: ;; Watcher didn't work:
(proc void)))))) (proc void))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(LOG "server started ------------------------------") (LOG "server started ------------------------------")
(define stop-status (serve-status HTTPS-PORT-NUMBER)) (define stop-status (serve-status HTTPS-PORT-NUMBER get-config))
(define session-count 0) (define session-count 0)
(parameterize ([error-display-handler (parameterize ([error-display-handler
@ -316,8 +351,7 @@
w w
(lambda (kill-watcher) (lambda (kill-watcher)
(let ([r-safe (make-limited-input-port r 1024)]) (let ([r-safe (make-limited-input-port r 1024)])
(fprintf w "handin\n") (ffprintf w "handin\n")
(flush-output w)
;; Check protocol: ;; Check protocol:
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
@ -326,17 +360,14 @@
(format "~e" exn))]) (format "~e" exn))])
(kill-watcher) (kill-watcher)
(LOG "ERROR: ~a" msg) (LOG "ERROR: ~a" msg)
(fprintf w "~s\n" msg) (ffprintf w "~s\n" msg)
(flush-output w)
;; see note on close-output-port below ;; see note on close-output-port below
(close-output-port w)))]) (close-output-port w)))])
(let ([protocol (read r-safe)]) (let ([protocol (read r-safe)])
(if (eq? protocol 'original) (if (eq? protocol 'original)
(begin (ffprintf w "original\n")
(fprintf w "original\n")
(flush-output w))
(error 'handin "unknown protocol: ~s" protocol))) (error 'handin "unknown protocol: ~s" protocol)))
(accept-submission-or-update assignment-list r r-safe w) (accept-submission-or-update (assignment-list) r r-safe w)
(LOG "normal exit") (LOG "normal exit")
(kill-watcher) (kill-watcher)
;; This close-output-port should not be necessary, and it's ;; This close-output-port should not be necessary, and it's

101
collects/handin-server/lock.ss
View File

@ -5,56 +5,61 @@
(provide wait-for-lock) (provide wait-for-lock)
;; wait-for-lock : string -> void ;; wait-for-lock : string -> void
;; Gets a lock on `user' for the calling thread; the lock ;; Gets a lock on `user' for the calling thread; the lock lasts until the
;; lasts until the calling thread terminates. ;; calling thread terminates. If the lock was actually acquired, then on
(define (wait-for-lock user) ;; 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)]) (let ([s (make-semaphore)])
(channel-put req-ch (make-req (channel-put req-ch
(thread-dead-evt (current-thread)) (make-req (thread-dead-evt (current-thread)) user s
user (and (pair? cleanup-thunk) (car cleanup-thunk))))
s))
(semaphore-wait s))) (semaphore-wait s)))
(define req-ch (make-channel)) (define req-ch (make-channel))
(define-struct req (thread-dead-evt
user
sema))
(thread (lambda () (define-struct req (thread-dead-evt user sema cleanup-thunk))
(let loop ([locks null]
[reqs null]) (thread
(let-values ([(locks reqs) (lambda ()
;; Try to satisfy lock requests: (let loop ([locks null]
(let loop ([reqs (reverse reqs)][locks locks][new-reqs null]) [reqs null])
(cond (let-values ([(locks reqs)
[(null? reqs) (values locks new-reqs)] ;; Try to satisfy lock requests:
[(assoc (req-user (car reqs)) locks) (let loop ([reqs (reverse reqs)]
;; Lock not available: [locks locks]
(loop (cdr reqs) locks (cons (car reqs) new-reqs))] [new-reqs null])
[else (if (null? reqs)
;; Lock is available, so take it: (values locks new-reqs)
(let ([req (car reqs)]) (let ([req (car reqs)]
(semaphore-post (req-sema req)) [rest (cdr reqs)])
(loop (cdr reqs) (cons (cons (req-user req) req) locks) new-reqs))]))]) (if (assoc (req-user req) locks)
(sync ;; Lock not available:
(handle-evt (loop rest locks (cons req new-reqs))
req-ch ;; Lock is available, so take it:
(lambda (req) (begin (semaphore-post (req-sema req))
(loop locks (cons req reqs)))) (loop (cdr reqs)
;; Release a lock whose thread is gone: (cons (cons (req-user req) req) locks)
(apply choice-evt new-reqs))))))])
(map (lambda (name+req) (sync
(handle-evt (handle-evt req-ch (lambda (req) (loop locks (cons req reqs))))
(req-thread-dead-evt (cdr name+req)) ;; Release a lock whose thread is gone:
(lambda (v) (apply choice-evt
(loop (remq name+req locks) reqs)))) (map (lambda (name+req)
locks)) (handle-evt
;; Throw away a request whose thread is gone: (req-thread-dead-evt (cdr name+req))
(apply choice-evt (lambda (v)
(map (lambda (req) ;; releasing a lock => run cleanup
(handle-evt (cond [(req-cleanup-thunk (cdr name+req))
(req-thread-dead-evt req) => (lambda (t) (t))])
(lambda (v) (loop (remq name+req locks) reqs))))
(loop locks (remq req reqs))))) locks))
reqs)))))))) ;; 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))))))))

2
collects/handin-server/status-web-root/htdocs/index.html
View File

@ -2,5 +2,7 @@
<head><title>Handin Status Web Server</title></head> <head><title>Handin Status Web Server</title></head>
<body> <body>
The handin status server is running. The handin status server is running.
<br>
You can <a href="/servlets/status.ss">check your submissions</a> on this server.
</body> </body>
</html> </html>

115
collects/handin-server/utils.ss
View File

@ -5,10 +5,11 @@
"run-status.ss" "run-status.ss"
(prefix pc: (lib "pconvert.ss")) (prefix pc: (lib "pconvert.ss"))
(lib "pretty.ss") (lib "pretty.ss")
(lib "list.ss")) (lib "list.ss")
(lib "string.ss"))
(provide unpack-submission (provide unpack-submission
unpack-test-suite-submission unpack-test-suite-submission
is-test-suite-submission? is-test-suite-submission?
@ -21,6 +22,7 @@
call-with-evaluator/submission call-with-evaluator/submission
reraise-exn-as-submission-problem reraise-exn-as-submission-problem
current-run-status current-run-status
current-value-printer
check-proc check-proc
check-defined check-defined
@ -130,6 +132,31 @@
(super-new))) (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 ---------------------------------------- ;; Execution ----------------------------------------
@ -149,27 +176,55 @@
(lambda () (lambda ()
;; First read program and evaluate it as a module: ;; First read program and evaluate it as a module:
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
(let ([prog-body (let* ([body
(parameterize ([read-case-sensitive #t] (parameterize ([read-case-sensitive #t]
[read-decimal-as-inexact #f]) [read-decimal-as-inexact #f])
(let loop ([l null]) (let loop ([l null])
(let ([expr (read-syntax 'program program-port)]) (let ([expr (read-syntax 'program program-port)])
(if (eof-object? expr) (if (eof-object? expr)
(reverse l) (reverse l)
(loop (cons expr l))))))]) (loop (cons expr l))))))]
(eval `(module m (lib ,(case language [body (append (if (and (pair? teachpacks)
[(beginner) "htdp-beginner.ss"] (eq? 'begin (car teachpacks)))
[(beginner-abbr) "htdp-beginner-abbr.ss"] (cdr teachpacks)
[(intermediate) "htdp-intermediate.ss"] (map (lambda (tp)
[(intermediate-lambda) "htdp-intermediate-lambda.ss"] `(,#'require
[(advanced) "htdp-advanced.ss"]) ,(if (pair? tp)
"lang") tp `(file ,tp))))
,@(map (lambda (tp) teachpacks))
`(,#'require (file ,tp))) body)]
teachpacks) [body
,@prog-body)) (cond
(eval `(require m)) [(and (symbol? language)
(current-namespace (module->namespace 'm))) (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)) (channel-put result-ch 'ok))
;; Now wait for interaction expressions: ;; Now wait for interaction expressions:
(let loop () (let loop ()
@ -177,7 +232,7 @@
(unless (eof-object? expr) (unless (eof-object? expr)
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn 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)))) (loop))))
(let loop () (let loop ()
(channel-put result-ch '(exn . no-more-to-evaluate)) (channel-put result-ch '(exn . no-more-to-evaluate))
@ -297,14 +352,14 @@
0)))))))) 0))))))))
(define list-abbreviation-enabled (make-parameter #f)) (define list-abbreviation-enabled (make-parameter #f))
(define (value-converter v) (define (value-converter v)
(parameterize ([pc:booleans-as-true/false #t] (parameterize ([pc:booleans-as-true/false #t]
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)] [pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
[pc:constructor-style-printing #t]) [pc:constructor-style-printing #t])
(pc:print-convert v))) (pc:print-convert v)))
(define (value-printer v) (define (default-value-printer v)
(parameterize ([pretty-print-show-inexactness #t] (parameterize ([pretty-print-show-inexactness #t]
[pretty-print-.-symbol-without-bars #t] [pretty-print-.-symbol-without-bars #t]
[pretty-print-exact-as-decimal #t] [pretty-print-exact-as-decimal #t]
@ -313,10 +368,11 @@
(let ([p (open-output-string)]) (let ([p (open-output-string)])
(pretty-print (value-converter v) p) (pretty-print (value-converter v) p)
(regexp-replace #rx"\n$" (get-output-string 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) (define (call-with-evaluator lang teachpacks program-port go)
(parameterize ([error-value->string-handler (lambda (v s) (parameterize ([error-value->string-handler (lambda (v s)
(value-printer v))] ((current-value-printer) v))]
[list-abbreviation-enabled (not (or (eq? lang 'beginner) [list-abbreviation-enabled (not (or (eq? lang 'beginner)
(eq? lang 'beginner-abbr)))]) (eq? lang 'beginner-abbr)))])
(reraise-exn-as-submission-problem (reraise-exn-as-submission-problem
@ -324,10 +380,9 @@
(let ([e (make-evaluator lang teachpacks program-port)]) (let ([e (make-evaluator lang teachpacks program-port)])
(current-run-status "executing your code") (current-run-status "executing your code")
(go e)))))) (go e))))))
(define (call-with-evaluator/submission lang teachpacks str go) (define (call-with-evaluator/submission lang teachpacks str go)
(let-values ([(defs interacts) (unpack-submission str)]) (let-values ([(defs interacts) (unpack-submission str)])
(call-with-evaluator lang teachpacks (open-input-text-editor defs) go))) (call-with-evaluator lang teachpacks (open-input-text-editor defs) go)))
)
)

19
collects/handin-server/web-status-server.ss
View File

@ -7,12 +7,21 @@
(lib "ssl-tcp-unit.ss" "net") (lib "ssl-tcp-unit.ss" "net")
(lib "tcp-sig.ss" "net") (lib "tcp-sig.ss" "net")
(lib "tcp-unit.ss" "net") (lib "tcp-unit.ss" "net")
(lib "file.ss")) (lib "file.ss")
(lib "etc.ss"))
(provide serve-status) (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 (define config
`((port ,port-no) `((port ,port-no)
(max-waiting 40) (max-waiting 40)
@ -37,10 +46,10 @@
(file-base-connection-timeout 30)) (file-base-connection-timeout 30))
(paths (paths
(configuration-root "conf") (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"))) (log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss")))
(file-root "htdocs") (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")))))) (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords"))))))
(virtual-host-table))) (virtual-host-table)))