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

* Main change: added active-dirs' and inactive-dirs' as configuration options

Browse Source 
instead of moving directories.
* Don't show solutions in active assignments, also check that when downloading
  files.
* Improved (no `suffix:') error messages for errors that users should
  eventually see.

svn: r5331
This commit is contained in:
Eli Barzilay 2007-01-12 07:40:24 +00:00
parent f6047d1bff
commit 812997204f
5 changed files with 244 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -51,9 +51,10 @@ Quick Start for a Test Drive:
"Chester Tester" "Chester Tester"
"123"))) "123")))
5. Make an "active" subdirectory in your new directory. 5. Make an "test" subdirectory in your new directory.
6. Make a "test" subdirectory in "active". 6. Create a file "config.ss" with the following content:
((active-dirs ("test")))
7. In your new directory, run 7. In your new directory, run
mred -mvqM handin-server mred -mvqM handin-server
@ -65,7 +66,7 @@ Quick Start for a Test Drive:
9. Start DrScheme, click "Handin" to run the client, submit with 9. Start DrScheme, click "Handin" to run the client, submit with
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 .../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
@ -164,13 +165,22 @@ sub-directories:
students with the handin client, "private-key.pem" is kept students with the handin client, "private-key.pem" is kept
private. private.
* "config.ss" (optional) --- configuration options. The file format * "config.ss" --- configuration options. The file format is
is
((<key> <val>) ...) ((<key> <val>) ...)
The following keys can be used (without the preceding quote): The following keys can be used (without the preceding quote):
'active-dirs : a list of directories that are active
submissions, relative to the current directory or absolute;
the last path element for each of these (and 'inactive-dirs
below) should be unique, and is used to identify the
submission (for example, in the client's submission dialog
and in the status servlet)
'inactive-dirs : a list of inactive submission directories (see
above for details)
'port-number : the port for the main handin server; the default 'port-number : the port for the main handin server; the default
is 7979 is 7979
@ -299,7 +309,8 @@ sub-directories:
don't save a copy that has inconsistent options: it is best to don't save a copy that has inconsistent options: it is best to
create a new configuration file and move it over the old one, or create a new configuration file and move it over the old one, or
use an editor that does so and not save until the new contents is use an editor that does so and not save until the new contents is
ready.) ready.) This is most useful for closing & openning submission
directories.
* "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
@ -362,22 +373,36 @@ sub-directories:
'plaintext symbol, which will be used without encryption. This 'plaintext symbol, which will be used without encryption. This
may be useful for manually resetting a forgotten passwords. may be useful for manually resetting a forgotten passwords.
* "active/" --- sub-directory for active assignments. A list of * "log" (or any other name that the 'log-file configuration option
active assignments is sent to a client tool when a student clicks specifies (if any), created if not present, appended otherwise)
"Handin", based on the contents of this directory. The student --- records connections and actions, where each entry is of the
then selects from the list. The assignments are ordered in the form
student's menu using `string<?', and the first assignment is the (id time-str msg-str)
default selection. [<id>|<time>] <msg>
where `<id>' is an integer representing the connection (numbered
consecutively from 1 when the server starts), "-" for a message
without a connection, and "wN" for a message from the status
servlet.
Within each directory, the student id is used for a sub-directory * Active and inactive assignment directories (which you can put in a
name. Within each student sub-directory are directories for handin nested directory for convenience, or specify a different absolute
attempts and successes. If a directory "ATTEMPT" exists, it directory), as specified by the configuration file using the
contains the most recent (unsuccessful) handin attempt. `active-dirs' and `inactive-dirs'. A list of active assignment
Directories "SUCCESS-n" (where n counts from 0) contain successful directories (the last path element in each specified path is used
handins; the lowest numbered such directory represents the latest as a label) is sent to the client tool when a student clicks
handin. "Handin". The assignment labels are ordered in the student's menu
using `string<?', and the first assignment is the default
selection.
A cleanup process in the server copies successful submission to Within each assignment directory, the student id is used for a
sub-directory name. Within each student sub-directory are
directories for handin attempts and successes. If a directory
"ATTEMPT" exists, it contains the most recent (unsuccessful or
currently-in-submission) handin attempt. Directories "SUCCESS-n"
(where n counts from 0) contain successful handins; the lowest
numbered such directory represents the latest handin.
A cleanup process in the server copies successful submissions to
the student directory -- one level up from the corresponding the student directory -- one level up from the corresponding
"SUCCESS-n" directory. This is done only for files and "SUCCESS-n" directory. This is done only for files and
directories that are newer in "SUCCESS-n" than in the submission directories that are newer in "SUCCESS-n" than in the submission
@ -388,12 +413,12 @@ sub-directories:
finish. When the server is started, it automatically runs the finish. When the server is started, it automatically runs the
cleanup process for each student directory. cleanup process for each student directory.
Within a student directory, a file "handin.scm" (or some other Within a student directory, a "handin.scm" file (or some other
name if `default-file-name' is set) contains the actual name if the `default-file-name' option is set) contains the actual
submission. A `checker' procedure can change this default file submission. A `checker' procedure can change this default file
name, and it can create additional files in an "ATTEMPT" directory name, and it can create additional files in an "ATTEMPT" directory
(to be copied by the cleanup process); see below on "checker.ss" (to be copied by the cleanup process); see below for more details
for more details. on "checker.ss".
For submissions from a normal DrScheme frame, a submission file For submissions from a normal DrScheme frame, a submission file
contains a copy of the student's definitions and interactions contains a copy of the student's definitions and interactions
@ -406,23 +431,23 @@ sub-directories:
To submit an assignment as a group, students use a concatenation To submit an assignment as a group, students use a concatenation
of usernames separated by "+" and any number of spaces (e.g., of usernames separated by "+" and any number of spaces (e.g.,
"user1+user2"). The same syntax ("user1+user2") is used for the "user1+user2"). The same syntax ("user1+user2") is used for the
directory for shared submissions, and the usernames are always directory for shared submissions, where the usernames are always
sorted so that the directory name is deterministic. Multiple sorted so that directory names are deterministic. Multiple
submissions for a particular user in different groups will be submissions for a particular user in different groups will be
rejected. rejected.
* "inactive/" --- sub-directory for inactive assignments, used by Inactive assignment directories are used by the the HTTPS status
the HTTPS status web server. web server.
* "active/<assignment>/checker.ss" (optional) --- a module that * "<active-dir>/<assignment>/checker.ss" (optional) --- a module
exports a `checker' function. This function receives two strings. that exports a `checker' function. This function receives two
The first is a username list and the second is the submission as a strings. The first is a username list and the second is the
byte string. (See also `unpack-submission', etc. from "util.ss", submission as a byte string. (See also `unpack-submission',
below.) To reject the submission, the `checker' function can etc. from "util.ss", below.) To reject the submission, the
raise an exception; the exception message will be relayed back to `checker' function can raise an exception; the exception message
the student. The module is loaded when the current directory is will be relayed back to the student. The module is loaded when
the main server directory, so it can read information from the current directory is the main server directory, so it can read
"config.ss". information from "config.ss".
The first argument is a list of usernames with at least one The first argument is a list of usernames with at least one
username, and more than one if this is a joint submission (where username, and more than one if this is a joint submission (where
@ -430,16 +455,16 @@ sub-directories:
by "+"). by "+").
The `checker' function is called with the current directory as The `checker' function is called with the current directory as
"active/<assignment>/<username(s)>/ATTEMPT", and the submission is "<active-assignment>/<username(s)>/ATTEMPT", and the submission is
saved in the file "handin", and the timeout clock is reset to the saved in the file "handin", and the timeout clock is reset to the
value of the 'session-timeout configuration. The checker function value of the 'session-timeout configuration. The checker function
can change "handin", and it can create additional files in this can change "handin", and it can create additional files in this
directory. (Extra files in the current directory will be directory. (Extra files in the current directory will be
preserved as it is later renamed to "SUCCESS-0", and copied to the preserved as it is later renamed to "SUCCESS-0", and copied to the
submission's root ("active/<assignment>/<user/s>/"), etc.) To submission's root ("<active-assignment>/<username(s)>/"), etc.)
hide generated files from the HTTPS status web server interface, To hide generated files from the HTTPS status web server
put the files in a subdirectory, which is preserved but hidden interface, put the files in a subdirectory, it is preserved but
from the status interface. hidden from the status interface.
The checker should return a string, such as "handin.scm", to use The checker should return a string, such as "handin.scm", to use
in naming the submission file, or #f to indicate that he file in naming the submission file, or #f to indicate that he file
@ -469,31 +494,22 @@ sub-directories:
To specify only pre/post-checker, use #f for the one you want to To specify only pre/post-checker, use #f for the one you want to
omit. omit.
* "log" (or any other name that the 'log-file configuration option * "<[in]active-assignment>/<user(s)>/<filename>" (if submitted) ---
specifies (if any), created if not present, appended otherwise) the most recent submission for <[in]active-assignment> by
--- records connections and actions, where each entry is of the <user(s)> where <filename> was returned by the checker (or the
form value of the `default-file-name' configuration option if there's
(id time-str msg-str) no checker). If the submission is from multiple users, then
[<id>|<time>] <msg> "<user(s)>" is actually "<user1>+<user2>" etc. Also, if the
where `<id>' is an integer representing the connection (numbered cleanup process was interrupted (by a machine failure, etc.), the
consecutively from 1 when the server starts), "-" for a message submission may actually be in "SUCCESS-n" as described above, but
without a connection, and "wN" for a message from the status will move up when the server performs a cleanup (or when
servlet. restarted).
* "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the * "<[in]active-assignment>/<user(s)>/grade" (optional) ---
most recent submission for <assignment> by <user> where <filename> <user(s)>'s grade for <assignment>, to be reported by the HTTPS
was returned by the checker (or the value of the status web server
`default-file-name' configuration option if there's no checker).
If the submission is from multiple users, then "<user>" is
actually "<user1>+<user2>" etc. Also, if the cleanup process was
interrupted (by a machine failure, etc.), the submission may
actually be in "SUCCESS-n" as described above.
* "[in]active/<assignment>/<user>/grade" (optional) --- <user>'s * "<[in]active-assignment>/solution*" --- the solution to the
grade for <assignment>, to be reported by the HTTPS status web
server
* "[in]active/<assignment>/solution*" --- 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. The solution can be either a file or a directory with a logs in. The solution can be either a file or a directory with a
name that begins with "solution". In the first case, the status name that begins with "solution". In the first case, the status
@ -510,7 +526,9 @@ related crashes.
The server currently provides no mechanism for a graceful shutdown, The server currently provides no mechanism for a graceful shutdown,
but terminating the server is no worse than a network outage. (In but terminating the server is no worse than a network outage. (In
particular, no data should be lost.) To reconfigure the server (e.g., particular, no data should be lost.) To reconfigure the server (e.g.,
to change the set of active assignments), stop it and restart it. to change a checker module), stop it and restart it. (Changing the
configuration file is detected, and options are reloaded, so no
restart is needed for that.)
The client and server are designed to be robust against network The client and server are designed to be robust against network
problems and timeouts. The client-side tool always provides a problems and timeouts. The client-side tool always provides a
@ -691,7 +709,8 @@ The _utils.ss_ module provides utilities helpful in implementing
Produces a line in the server log file, using the given format Produces a line in the server log file, using the given format
string and arguments. All this actually does, is arrange to print string and arguments. All this actually does, is arrange to print
the line fast (to avoid mixing lines from different threads) to the the line fast (to avoid mixing lines from different threads) to the
error port, and flush it. error port, and flush it. (The log port will prefix all lines with
a time stamp and connection identifier.)
> (timeout-control msg) > (timeout-control msg)
Control the timeout for this session. The timeout is initialized by Control the timeout for this session. The timeout is initialized by
@ -848,13 +867,12 @@ Keywords for configuring `check:':
`current-value-printer' (see above). `current-value-printer' (see above).
* :coverage? -- collect coverage information when evaluating the * :coverage? -- collect coverage information when evaluating the
submission. This will submission. This will cause an error if some input is not covered.
cause an error if some input is not covered. This check happens This check happens after checker tests are run, but the information
after checker tests are run, but the information is collected and is collected and stored before, so checker tests do not change the
stored before, so checker tests do not change the result. Also, you result. Also, you can use the `!all-covered' procedure in the
can use the `!all-covered' procedure in the checker before other checker before other tests, if you want that feedback earlier. Does
tests, if you want that feedback earlier. not work with non-textual submissions.
Does not work with non-textual submissions.
Within the body of `check:', `users' and `submission' will be bound to Within the body of `check:', `users' and `submission' will be bound to
the checker arguments -- a (sorted) list of usernames and the the checker arguments -- a (sorted) list of usernames and the

17
collects/handin-server/extra-utils.ss
View File

@ -30,8 +30,8 @@
(provide submission-dir) (provide submission-dir)
(define submission-dir-re (define submission-dir-re
(regexp (string-append "[/\\]active[/\\]([^/\\]+)[/\\](?:[^/\\]+)" (regexp (string-append "[/\\]([^/\\]+)[/\\](?:[^/\\]+)[/\\]"
"[/\\](?:SUCCESS-[0-9]+|ATTEMPT)[/\\]?$"))) "(?:SUCCESS-[0-9]+|ATTEMPT)[/\\]?$")))
(define (submission-dir) (define (submission-dir)
(let ([m (regexp-match submission-dir-re (let ([m (regexp-match submission-dir-re
(path->string (current-directory)))]) (path->string (current-directory)))])
@ -165,10 +165,9 @@
(read-bytes-line (current-input-port) 'any)))]) (read-bytes-line (current-input-port) 'any)))])
(unless (eof-object? line) (unless (eof-object? line)
(let* ([line (regexp-replace #rx#"[ \t]+$" line #"")] (let* ([line (regexp-replace #rx#"[ \t]+$" line #"")]
[line (if (and untabify? [line (if (and untabify? (regexp-match? #rx"\t" line))
(regexp-match-positions #rx"\t" line))
(untabify line) line)]) (untabify line) line)])
(when (and bad-re (regexp-match bad-re line)) (when (and bad-re (regexp-match? bad-re line))
(error* "You cannot use \"~a\" in ~a!~a" (error* "You cannot use \"~a\" in ~a!~a"
(if (regexp? bad-re) (object-name bad-re) bad-re) (if (regexp? bad-re) (object-name bad-re) bad-re)
(currently-processed-file-name) (currently-processed-file-name)
@ -285,14 +284,14 @@
(let* ([files (read-multifile (open-input-bytes submission))] (let* ([files (read-multifile (open-input-bytes submission))]
[names (map car files)]) [names (map car files)])
(cond [(ormap (lambda (f) (cond [(ormap (lambda (f)
(and (regexp-match #rx"^[.]|[/\\ ]" (car f)) (car f))) (and (regexp-match? #rx"^[.]|[/\\ ]" (car f)) (car f)))
files) files)
=> (lambda (file) (error* "bad filename: ~e" file))]) => (lambda (file) (error* "bad filename: ~e" file))])
(cond [(procedure? names-checker) (names-checker names)] (cond [(procedure? names-checker) (names-checker names)]
[(or (regexp? names-checker) [(or (regexp? names-checker)
(string? names-checker) (bytes? names-checker)) (string? names-checker) (bytes? names-checker))
(cond [(ormap (lambda (n) (cond [(ormap (lambda (n)
(and (not (regexp-match names-checker n)) n)) (and (not (regexp-match? names-checker n)) n))
names) names)
=> (lambda (file) (error* "bad filename: ~e" file))])] => (lambda (file) (error* "bad filename: ~e" file))])]
[(and (list? names-checker) (andmap string? names-checker)) [(and (list? names-checker) (andmap string? names-checker))
@ -376,7 +375,7 @@
(syntax-case stx () (syntax-case stx ()
[(key val x ...) [(key val x ...)
(and (identifier? #'key) (and (identifier? #'key)
(regexp-match #rx"^:" (symbol->string (syntax-e #'key)))) (regexp-match? #rx"^:" (symbol->string (syntax-e #'key))))
(loop #'(x ...) (cons (list (syntax-e #'key) #'key #'val) keyvals))] (loop #'(x ...) (cons (list (syntax-e #'key) #'key #'val) keyvals))]
[(body ...) [(body ...)
(with-syntax (with-syntax
@ -530,7 +529,7 @@
[(not (string? user-error-message)) [(not (string? user-error-message))
(error* (error*
"badly configured user-error-message")] "badly configured user-error-message")]
[(regexp-match #rx"~[aesvAESV]" [(regexp-match? #rx"~[aesvAESV]"
user-error-message) user-error-message)
(error* user-error-message m)] (error* user-error-message m)]
[else [else

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

@ -15,6 +15,10 @@
(install-logger-port) (install-logger-port)
;; errors to the user: no need for a "foo: " prefix
(define (error* fmt . args)
(error (apply format fmt args)))
(define (write+flush port . xs) (define (write+flush port . xs)
(for-each (lambda (x) (write x port) (newline port)) xs) (for-each (lambda (x) (write x port) (newline port)) xs)
(flush-output port)) (flush-output port))
@ -45,9 +49,8 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ATTEMPT-DIR "ATTEMPT") (define ATTEMPT-DIR "ATTEMPT")
(define (success-dir n) (format "SUCCESS-~a" n))
(define (success-dir 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)])
(when (directory-exists? name) (when (directory-exists? name)
@ -111,37 +114,29 @@
(define (cleanup-all-submissions) (define (cleanup-all-submissions)
(log-line "Cleaning up all submission directories") (log-line "Cleaning up all submission directories")
(for-each (lambda (top)
(when (directory-exists? top)
(parameterize ([current-directory top])
(for-each (lambda (pset) (for-each (lambda (pset)
(when (directory-exists? pset) ; filter non-dirs (when (directory-exists? pset) ; just in case
(parameterize ([current-directory pset]) (parameterize ([current-directory pset])
(for-each (lambda (sub) (for-each (lambda (sub)
(when (directory-exists? sub) (when (directory-exists? sub) ; filter non-dirs
(cleanup-submission sub))) (cleanup-submission sub)))
(directory-list))))) (directory-list)))))
(directory-list))))) (get-conf 'all-dirs)))
'("active" "inactive")))
;; On startup, we scan all submissions, then repeat at random intervals (only ;; On startup, we scan all submissions, then repeat at random intervals (only
;; if clients connected in that time), and check often for changes in the ;; if clients connected in that time), and check often for changes in the
;; active/inactive directories and run a cleanup if there was a change ;; active/inactive directories and run a cleanup if there was a change
(define connection-num 0) (define connection-num 0)
(thread (lambda () (thread (lambda ()
(define last-active/inactive #f) (define last-all-dirs #f)
(define last-connection-num #f) (define last-connection-num #f)
(let loop () (let loop ()
(let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay (let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
(when (>= n 0) (when (>= n 0)
(let ([new (map (lambda (x) (let ([new (get-conf 'all-dirs)])
(if (directory-exists? x) (if (equal? new last-all-dirs)
(directory-list x)
null))
'("active" "inactive"))])
(if (equal? new last-active/inactive)
(begin (sleep 30) (loop (sub1 n))) (begin (sleep 30) (loop (sub1 n)))
(begin (set! last-active/inactive new) (begin (set! last-all-dirs new)
(set! last-connection-num #f)))))) (set! last-connection-num #f))))))
(unless (equal? last-connection-num connection-num) (unless (equal? last-connection-num connection-num)
(cleanup-all-submissions) (cleanup-all-submissions)
@ -154,27 +149,28 @@
(with-output-to-file part (with-output-to-file part
(lambda () (display s)))) (lambda () (display s))))
(define (users->dirname users)
(apply string-append (car users)
(map (lambda (u) (string-append "+" u)) (cdr users))))
(define (accept-specific-submission data r r-safe w) (define (accept-specific-submission data r r-safe w)
;; Note: users are always sorted ;; Note: users are always sorted
(define users (a-ref data 'usernames)) (define users (a-ref data 'usernames))
(define assignments (a-ref data 'assignments)) (define assignments (a-ref data 'assignments))
(define assignment (a-ref data 'assignment)) (define assignment (a-ref data 'assignment))
(define dirname (define dirname (users->dirname users))
(apply string-append (car users)
(map (lambda (u) (string-append "+" u)) (cdr users))))
(define len #f) (define len #f)
(unless (member assignment assignments) (unless (member assignment assignments)
(error 'handin "not an active assignment: ~a" assignment)) (error* "not an active assignment: ~a" assignment))
(log-line "assignment for ~a: ~a" users assignment) (log-line "assignment for ~a: ~a" users assignment)
(write+flush w 'ok) (write+flush w 'ok)
(set! len (read r-safe)) (set! len (read r-safe))
(unless (and (number? len) (integer? len) (positive? len)) (unless (and (number? len) (integer? len) (positive? len))
(error 'handin "bad length: ~s" len)) (error* "bad length: ~s" len))
(unless (len . < . (get-conf 'max-upload)) (unless (len . < . (get-conf 'max-upload))
(error 'handin (error* "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
"max handin file size is ~s bytes, file to handin is too big (~s bytes)"
(get-conf 'max-upload) len)) (get-conf 'max-upload) len))
(parameterize ([current-directory (build-path "active" assignment)]) (parameterize ([current-directory (assignment<->dir assignment)])
(wait-for-lock dirname (wait-for-lock dirname
(let ([dir (build-path (current-directory) dirname)]) (let ([dir (build-path (current-directory) dirname)])
(lambda () (cleanup-submission dir)))) (lambda () (cleanup-submission dir))))
@ -183,10 +179,10 @@
(for-each wait-for-lock users)) (for-each wait-for-lock users))
(write+flush w 'go) (write+flush w 'go)
(unless (regexp-match #rx"[$]" r-safe) (unless (regexp-match #rx"[$]" r-safe)
(error 'handin "did not find start-of-content marker")) (error* "did not find start-of-content marker"))
(let ([s (read-bytes len r)]) (let ([s (read-bytes len r)])
(unless (and (bytes? s) (= (bytes-length s) len)) (unless (and (bytes? s) (= (bytes-length s) len))
(error 'handin "error uploading (got ~e, expected ~s bytes)" (error* "error uploading (got ~e, expected ~s bytes)"
(if (bytes? s) (bytes-length s) s) len)) (if (bytes? s) (bytes-length s) s) len))
;; we have a submission, need to create a directory if needed, make ;; we have a submission, need to create a directory if needed, make
;; sure that no users submitted work with someone else ;; sure that no users submitted work with someone else
@ -196,8 +192,7 @@
(for-each (for-each
(lambda (d) (lambda (d)
(when (member d users) (when (member d users)
(error 'handin (error* "bad submission: ~a has an existing submission (~a)"
"bad submission: ~a has an existing submission (~a)"
d dir))) d dir)))
(regexp-split #rx" *[+] *" (path->string dir)))) (regexp-split #rx" *[+] *" (path->string dir))))
(directory-list)) (directory-list))
@ -227,18 +222,18 @@
[(procedure? checker*) (values #f checker* #f)] [(procedure? checker*) (values #f checker* #f)]
[(and (list? checker*) (= 3 (length checker*))) [(and (list? checker*) (= 3 (length checker*)))
(apply values checker*)] (apply values checker*)]
[else (error 'handin-configuration [else (error* "bad checker value: ~e" checker*)]))
"bad checker value: ~e" checker*)]))
(when pre (when pre
(let ([dir (current-directory)]) (let ([dir (current-directory)])
(with-handlers (with-handlers
([void (lambda (e) ([void (lambda (e)
(parameterize ([current-directory dir]) (parameterize ([current-directory dir])
(unless (ormap (unless (ormap (lambda (d)
(lambda (d)
(and (directory-exists? d) (and (directory-exists? d)
(regexp-match SUCCESS-RE d))) (regexp-match
(map path->string (directory-list))) SUCCESS-RE
(path->string d))))
(directory-list))
(parameterize ([current-directory ".."]) (parameterize ([current-directory ".."])
(when (directory-exists? dirname) (when (directory-exists? dirname)
(delete-directory/files dirname))))) (delete-directory/files dirname)))))
@ -265,23 +260,21 @@
(when post (when post
(parameterize ([current-directory (success-dir 0)]) (parameterize ([current-directory (success-dir 0)])
(post users s)))) (post users s))))
(error 'handin "upload not confirmed: ~s" v))))))))) (error* "upload not confirmed: ~s" v)))))))))
(define (retrieve-specific-submission data w) (define (retrieve-specific-submission data w)
;; Note: users are always sorted ;; Note: users are always sorted
(define users (a-ref data 'usernames)) (define users (a-ref data 'usernames))
(define assignments (a-ref data 'assignments)) (define assignments (a-ref data 'assignments))
(define assignment (a-ref data 'assignment)) (define assignment (a-ref data 'assignment))
(define dirname (define dirname (users->dirname users))
(apply string-append (car users) (define submission-dir (build-path (assignment<->dir assignment) dirname))
(map (lambda (u) (string-append "+" u)) (cdr users))))
(define submission-dir (build-path "active" assignment dirname))
(unless (member assignment assignments) (unless (member assignment assignments)
(error 'handin "not an active assignment: ~a" assignment)) (error* "not an active assignment: ~a" assignment))
(unless (directory-exists? submission-dir) (unless (directory-exists? submission-dir)
(error 'handin "no ~a submission directory for ~a" assignment users)) (error* "no ~a submission directory for ~a" assignment users))
(log-line "retrieving assignment for ~a: ~a" users assignment) (log-line "retrieving assignment for ~a: ~a" users assignment)
(parameterize ([current-directory (build-path "active" assignment dirname)]) (parameterize ([current-directory submission-dir])
(define magics '(#"WXME" #"<<<MULTI-SUBMISSION-FILE>>>")) (define magics '(#"WXME" #"<<<MULTI-SUBMISSION-FILE>>>"))
(define mlen (apply max (map bytes-length magics))) (define mlen (apply max (map bytes-length magics)))
(define file (define file
@ -307,7 +300,7 @@
(display "$" w) (display "$" w)
(display (with-input-from-file file (lambda () (read-bytes len))) w) (display (with-input-from-file file (lambda () (read-bytes len))) w)
(flush-output w)) (flush-output w))
(error 'handin "no ~a submission file found for ~a" assignment users)))) (error* "no ~a submission file found for ~a" assignment users))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -321,7 +314,7 @@
(put-preferences (put-preferences
(list (string->symbol username)) (list data) (list (string->symbol username)) (list data)
(lambda (f) (lambda (f)
(error 'handin "user database busy; please try again, and alert the adminstrator if problems persist")) (error* "user database busy; please try again, and alert the adminstrator if problems persist"))
"users.ss")) "users.ss"))
orig-custodian)) orig-custodian))
@ -333,9 +326,8 @@
[(list? field-re) (member value field-re)] [(list? field-re) (member value field-re)]
[(not field-re) #t] [(not field-re) #t]
[(eq? field-re '-) #t] ; -> hidden field, no check [(eq? field-re '-) #t] ; -> hidden field, no check
[else (error 'handin "bad spec: field-regexp is ~e" [else (error* "bad spec: field-regexp is ~e" field-re)])
field-re)]) (error* "bad ~a: \"~a\"~a" field-name value
(error 'handin "bad ~a: \"~a\"~a" field-name value
(if field-desc (format "; need ~a" field-desc) "")))) (if field-desc (format "; need ~a" field-desc) ""))))
;; Utility for the next two functions: reconstruct a full list of ;; Utility for the next two functions: reconstruct a full list of
@ -354,24 +346,24 @@
(define user-fields (a-ref data 'user-fields)) (define user-fields (a-ref data 'user-fields))
(define extra-fields (add-hidden-to-user-fields user-fields)) (define extra-fields (add-hidden-to-user-fields user-fields))
(unless (get-conf 'allow-new-users) (unless (get-conf 'allow-new-users)
(error 'handin "new users not allowed: ~a" username)) (error* "new users not allowed: ~a" username))
(check-field username (get-conf 'user-regexp) "username" (check-field username (get-conf 'user-regexp) "username"
(get-conf 'user-desc)) (get-conf 'user-desc))
;; Since we're going to use the username in paths, and + to split names: ;; Since we're going to use the username in paths, and + to split names:
(when (regexp-match #rx"[+/\\:|\"<>]" username) (when (regexp-match #rx"[+/\\:|\"<>]" username)
(error 'handin "username must not contain one of the following: + / \\ : | \" < >")) (error* "username must not contain these characters: + / \\ : | \" < >"))
(when (regexp-match (when (regexp-match
#rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?" #rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
(string-foldcase username)) (string-foldcase username))
(error 'handin "username must not be a Windows special file name")) (error* "username must not be a Windows special file name"))
(when (regexp-match #rx"^[ .]|[ .]$" username) (when (regexp-match #rx"^[ .]|[ .]$" username)
(error 'handin "username must not begin or end with a space or period")) (error* "username must not begin or end with a space or period"))
(when (regexp-match #rx"^solution" username) (when (regexp-match #rx"^solution" username)
(error 'handin "the username prefix \"solution\" is reserved")) (error* "the username prefix \"solution\" is reserved"))
(when (string=? "checker.ss" username) (when (string=? "checker.ss" username)
(error 'handin "the username \"checker.ss\" is reserved")) (error* "the username \"checker.ss\" is reserved"))
(when (get-user-data username) (when (get-user-data username)
(error 'handin "username already exists: `~a'" username)) (error* "username already exists: `~a'" username))
(for-each (lambda (str info) (for-each (lambda (str info)
(check-field str (cadr info) (car info) (caddr info))) (check-field str (cadr info) (car info) (caddr info)))
extra-fields (get-conf 'extra-fields)) extra-fields (get-conf 'extra-fields))
@ -386,17 +378,16 @@
(define user-fields (a-ref data 'user-fields)) (define user-fields (a-ref data 'user-fields))
(define extra-fields (add-hidden-to-user-fields user-fields)) (define extra-fields (add-hidden-to-user-fields user-fields))
(unless (= 1 (length usernames)) (unless (= 1 (length usernames))
(error 'handin "cannot change a password for multiple users: ~a" (error* "cannot change a password for multiple users: ~a" usernames))
usernames))
;; the new data is the same as the old one for every empty string (includes ;; the new data is the same as the old one for every empty string (includes
;; hidden fields) ;; hidden fields)
(let ([new-data (map (lambda (old new) (if (equal? "" new) old new)) (let ([new-data (map (lambda (old new) (if (equal? "" new) old new))
(car user-datas) (cons passwd extra-fields))]) (car user-datas) (cons passwd extra-fields))])
(unless (or (get-conf 'allow-change-info) (unless (or (get-conf 'allow-change-info)
(equal? (cdr new-data) (cdar user-datas))) (equal? (cdr new-data) (cdar user-datas)))
(error 'handin "changing information not allowed: ~a" (car usernames))) (error* "changing information not allowed: ~a" (car usernames)))
(when (equal? new-data (car user-datas)) (when (equal? new-data (car user-datas))
(error 'handin "no fields changed: ~a" (car usernames))) (error* "no fields changed: ~a" (car usernames)))
(for-each (lambda (str info) (for-each (lambda (str info)
(check-field str (cadr info) (car info) (caddr info))) (check-field str (cadr info) (car info) (caddr info)))
(cdr new-data) (get-conf 'extra-fields)) (cdr new-data) (get-conf 'extra-fields))
@ -407,7 +398,7 @@
(define (get-user-info data) (define (get-user-info data)
(define usernames (a-ref data 'usernames)) (define usernames (a-ref data 'usernames))
(unless (= 1 (length usernames)) (unless (= 1 (length usernames))
(error 'handin "cannot get user-info for multiple users: ~a" usernames)) (error* "cannot get user-info for multiple users: ~a" usernames))
;; filter out hidden fields ;; filter out hidden fields
(let ([all-data (cdar (a-ref data 'user-datas))]) (let ([all-data (cdar (a-ref data 'user-datas))])
(filter values (map (lambda (d f) (filter values (map (lambda (d f)
@ -426,7 +417,7 @@
(define (good? passwd) (define (good? passwd)
(define (bad-password msg) (define (bad-password msg)
(log-line "ERROR: ~a -- ~s" msg passwd) (log-line "ERROR: ~a -- ~s" msg passwd)
(error 'handin "bad password in user database")) (error* "bad password in user database"))
(cond [(string? passwd) (equal? md5 passwd)] (cond [(string? passwd) (equal? md5 passwd)]
[(and (list? passwd) (= 2 (length passwd)) [(and (list? passwd) (= 2 (length passwd))
(symbol? (car passwd)) (string? (cadr passwd))) (symbol? (car passwd)) (string? (cadr passwd)))
@ -513,7 +504,7 @@
(cons (get-conf 'master-password) (cons (get-conf 'master-password)
(map car user-datas))))) (map car user-datas)))))
(log-line "failed login: ~a" (a-ref data 'username/s)) (log-line "failed login: ~a" (a-ref data 'username/s))
(error 'handin "bad username or password for ~a" (error* "bad username or password for ~a"
(a-ref data 'username/s))) (a-ref data 'username/s)))
(log-line "login: ~a" usernames)) (log-line "login: ~a" usernames))
(case msg (case msg
@ -525,7 +516,7 @@
(write+flush w 'ok)) ; final confirmation for *all* actions (write+flush w 'ok)) ; final confirmation for *all* actions
(define (assignment-list) (define (assignment-list)
(sort (map path->string (directory-list "active")) string<?)) (map assignment<->dir (get-conf 'active-dirs)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

27
collects/handin-server/private/config.ss
View File

@ -19,7 +19,6 @@
(unless (and raw-config (unless (and raw-config
(< (- (current-inexact-milliseconds) last-poll) poll-freq)) (< (- (current-inexact-milliseconds) last-poll) poll-freq))
(set! last-poll (current-inexact-milliseconds)) (set! last-poll (current-inexact-milliseconds))
(printf "polling...\n")
(let ([filetime (file-or-directory-modify-seconds config-file)]) (let ([filetime (file-or-directory-modify-seconds config-file)])
(unless (and filetime (equal? filetime last-filetime)) (unless (and filetime (equal? filetime last-filetime))
(set! last-filetime filetime) (set! last-filetime filetime)
@ -28,7 +27,6 @@
(error 'get-conf (error 'get-conf
"could not read conf (~a)" "could not read conf (~a)"
config-file))]) config-file))])
(printf "reading...\n")
(with-input-from-file config-file read))) (with-input-from-file config-file read)))
(set! config-cache (make-hash-table))))) (set! config-cache (make-hash-table)))))
(hash-table-get config-cache key (hash-table-get config-cache key
@ -46,9 +44,12 @@
(define (rx s) (if (regexp? s) s (regexp s))) (define (rx s) (if (regexp? s) s (regexp s)))
(define (path p) (path->complete-path p server-dir)) (define (path p) (path->complete-path p server-dir))
(define (path/false p) (and p (path p))) (define (path/false p) (and p (path p)))
(define (path-list l) (map path l))
(define (config-default+translate which) (define (config-default+translate which)
(case which (case which
[(active-dirs) (values '() path-list )]
[(inactive-dirs) (values '() path-list )]
[(port-number) (values 7979 id )] [(port-number) (values 7979 id )]
[(https-port-number) (values (add1 (get-conf 'port-number)) id )] [(https-port-number) (values (add1 (get-conf 'port-number)) id )]
[(session-timeout) (values 300 id )] [(session-timeout) (values 300 id )]
@ -73,10 +74,32 @@
"a valid email address")) "a valid email address"))
id)] id)]
;; computed from the above (mark by translate = #f) ;; computed from the above (mark by translate = #f)
[(all-dirs)
(values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)]
[(names-dirs) ; see below
(values (paths->map (get-conf 'all-dirs)) #f)]
[(user-fields) [(user-fields)
(values (filter (lambda (f) (not (eq? '- (cadr f)))) (values (filter (lambda (f) (not (eq? '- (cadr f))))
(get-conf 'extra-fields)) (get-conf 'extra-fields))
#f)] #f)]
[else (error 'get-conf "unknown configuration entry: ~s" which)])) [else (error 'get-conf "unknown configuration entry: ~s" which)]))
;; This is used below to map names to submission directory paths and back
;; returns a (list-of (either (list name path) (list path name)))
(define (paths->map dirs)
(define (path->name dir)
(unless (directory-exists? dir)
(error 'get-conf
"directory entry for an inexistent directory: ~e" dir))
(let-values ([(_1 name _2) (split-path dir)])
(bytes->string/locale (path-element->bytes name))))
(let ([names (map path->name dirs)])
(append (map list names dirs) (map list dirs names))))
;; Translates an assignment name to a directory path or back
(provide assignment<->dir)
(define (assignment<->dir a/d)
(cond [(assoc a/d (get-conf 'names-dirs)) => cadr]
[else (error 'assignment<->dir "internal error: ~e" a/d)]))
) )

82
collects/handin-server/status-web-root/servlets/status.ss
View File

@ -10,10 +10,6 @@
(lib "logger.ss" "handin-server" "private") (lib "logger.ss" "handin-server" "private")
(lib "config.ss" "handin-server" "private")) (lib "config.ss" "handin-server" "private"))
(define active-dir (build-path server-dir "active"))
(define inactive-dir (build-path server-dir "inactive"))
(define active/inactive-dirs (list active-dir inactive-dir))
(define get-user-data (define get-user-data
(let ([users-file (build-path server-dir "users.ss")]) (let ([users-file (build-path server-dir "users.ss")])
(lambda (user) (lambda (user)
@ -40,7 +36,7 @@
"/"))))) "/")))))
(define (make-k k tag) (define (make-k k tag)
(format "~a~atag=~a" k (if (regexp-match #rx"^[^#]*[?]" k) "&" "?") (format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")
(uri-encode (regexp-replace handin-prefix-re (uri-encode (regexp-replace handin-prefix-re
(if (path? tag) (path->string tag) tag) (if (path? tag) (path->string tag) tag)
"")))) ""))))
@ -51,24 +47,22 @@
;; `look-for' can be a username as a string (will find "bar+foo" for "foo"), ;; `look-for' can be a username as a string (will find "bar+foo" for "foo"),
;; or a regexp that should match the whole directory name (used with ;; or a regexp that should match the whole directory name (used with
;; "^solution" below) ;; "^solution" below)
(define (find-hi-entry hi look-for) (define (find-handin-entry hi look-for)
(define (find-submission top) (let ([dir (assignment<->dir hi)])
(let ([dir (build-path top hi)])
(and (directory-exists? dir) (and (directory-exists? dir)
(ormap (ormap
(lambda (d) (lambda (d)
(let ([d (path->string d)]) (let ([d (path->string d)])
(and (cond [(string? look-for) (and (cond [(string? look-for)
(member look-for (regexp-split #rx" *[+] *" d))] (member look-for (regexp-split #rx" *[+] *" d))]
[(regexp? look-for) (regexp-match look-for d)] [(regexp? look-for) (regexp-match? look-for d)]
[else (error 'find-hi-entry [else (error 'find-handin-entry
"internal error: ~e" look-for)]) "internal error: ~e" look-for)])
(build-path dir d)))) (build-path dir d))))
(directory-list dir))))) (directory-list dir)))))
(ormap find-submission active/inactive-dirs))
(define (handin-link k user hi) (define (handin-link k user hi)
(let* ([dir (find-hi-entry hi user)] (let* ([dir (find-handin-entry hi user)]
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)]) [l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
(parameterize ([current-directory dir]) (parameterize ([current-directory dir])
(sort (filter (lambda (f) (sort (filter (lambda (f)
@ -94,7 +88,8 @@
user hi))))) user hi)))))
(define (solution-link k hi) (define (solution-link k hi)
(let ([soln (find-hi-entry hi #rx"^solution")] (let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs))
(find-handin-entry hi #rx"^solution"))]
[none `((i "---"))]) [none `((i "---"))])
(cond [(not soln) none] (cond [(not soln) none]
[(file-exists? soln) [(file-exists? soln)
@ -115,7 +110,7 @@
[else none]))) [else none])))
(define (handin-grade user hi) (define (handin-grade user hi)
(let* ([dir (find-hi-entry hi user)] (let* ([dir (find-handin-entry hi user)]
[grade (and dir [grade (and dir
(let ([filename (build-path dir "grade")]) (let ([filename (build-path dir "grade")])
(and (file-exists? filename) (and (file-exists? filename)
@ -140,51 +135,42 @@
(define re:base #rx"^([a-zA-Z]*)([0-9]+)") (define re:base #rx"^([a-zA-Z]*)([0-9]+)")
(define (all-status-page user) (define (all-status-page user)
(let* ([l (sort (define (cell . texts) `(td ([bgcolor "white"]) ,@texts))
(map path->string (define (rcell . texts) `(td ([bgcolor "white"] [align "right"]) ,@texts))
(append (directory-list active-dir) (define (header . texts) `(td ([bgcolor "#f0f0f0"]) (big (strong ,@texts))))
(with-handlers ([exn:fail? (lambda (x) null)]) (define ((row k active?) dir)
(directory-list inactive-dir)))) (let ([hi (assignment<->dir dir)])
(lambda (a b) `(tr ([valign "top"])
(let ([am (regexp-match re:base a)] ,(apply header hi
[bm (regexp-match re:base b)]) (if active? `((br) (small (small "[active]"))) '()))
(if (and am bm ,(apply cell (handin-link k user hi))
(string=? (cadr am) (cadr bm))) ,(rcell (handin-grade user hi))
(or (< (string->number (caddr am)) ,(apply cell (solution-link k hi)))))
(string->number (caddr bm))) (let* ([next
(string<? a b))
(string<? a b)))))]
[next
(send/suspend (send/suspend
(lambda (k) (lambda (k)
(define (header text)
`(td ((bgcolor "#f0f0f0")) (big (strong ,text))))
(make-page (make-page
(format "All Handins for ~a" user) (format "All Handins for ~a" user)
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"]) `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution"))) (tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
,@(map (lambda (hi) ,@(append (map (row k #t) (get-conf 'active-dirs))
`(tr ([valign "top"]) (map (row k #f) (get-conf 'inactive-dirs)))))))]
,(header hi)
(td ([bgcolor "white"]) ,@(handin-link k user hi))
(td ([bgcolor "white"] (align "right")) ,(handin-grade user hi))
(td ([bgcolor "white"]) ,@(solution-link k hi))))
l)))))]
[tag (select-k next)]) [tag (select-k next)])
(download user tag))) (download user tag)))
(define (download who tag) (define (download who tag)
(define (check path elts) (define (check path elts allow-active?)
(let loop ([path path] [elts (reverse elts)]) (let loop ([path path] [elts (reverse elts)])
(let*-values ([(base name dir?) (split-path path)] (let*-values ([(base name dir?) (split-path path)]
[(name) (path->string name)] [(name) (path->string name)]
[(check) (and (pair? elts) (car elts))]) [(check) (and (pair? elts) (car elts))])
(if (null? elts) (if (null? elts)
;; must be rooted in active/inactive (why build-path instead of ;; must be rooted in a submission directory (why build-path instead
;; using `path'? -- because path will have a trailing slash) ;; of using `path'? -- because path will have a trailing slash)
(member (build-path base name) active/inactive-dirs) (member (build-path base name)
(get-conf (if allow-active? 'all-dirs 'inactive-dirs)))
(and (cond [(eq? '* check) #t] (and (cond [(eq? '* check) #t]
[(regexp? check) (regexp-match check name)] [(regexp? check) (regexp-match? check name)]
[(string? check) [(string? check)
(or (equal? name check) (or (equal? name check)
(member check (regexp-split #rx" *[+] *" name)))] (member check (regexp-split #rx" *[+] *" name)))]
@ -194,16 +180,16 @@
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail? (lambda (exn)
(make-page "Error" "Illegal file access"))]) (make-page "Error" "Illegal file access"))])
;; Make sure the user is allowed to read the requested file: ;; Make sure the user is allowed to read the requested file:
(or (check file `(* ,who *)) (or (check file `(,who *) #t)
(check file `(* #rx"^solution")) (check file `(#rx"^solution") #f)
(check file `(* #rx"^solution" *)) (check file `(#rx"^solution" *) #f)
(error "Boom!")) (error "Boom!"))
(log-line "Status file-get: ~s ~a" who file) (log-line "Status file-get: ~s ~a" who file)
;; Return the downloaded file ;; Return the downloaded file
(let* ([data (with-input-from-file file (let* ([data (with-input-from-file file
(lambda () (read-bytes (file-size file))))] (lambda () (read-bytes (file-size file))))]
[html? (regexp-match #rx"[.]html?$" (string-foldcase tag))] [html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match #rx#"^WXME" data)]) [wxme? (regexp-match? #rx#"^WXME" data)])
(make-response/full 200 "Okay" (current-seconds) (make-response/full 200 "Okay" (current-seconds)
(cond [html? #"text/html"] (cond [html? #"text/html"]
[wxme? #"application/data"] [wxme? #"application/data"]