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

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

@ -51,9 +51,10 @@ Quick Start for a Test Drive:
"Chester Tester"
"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
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
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
https://localhost:7980/servlets/status.ss
@ -164,13 +165,22 @@ sub-directories:
students with the handin client, "private-key.pem" is kept
private.
* "config.ss" (optional) --- configuration options. The file format
is
* "config.ss" --- configuration options. The file format is
((<key> <val>) ...)
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
is 7979
@ -299,7 +309,8 @@ sub-directories:
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
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
the list of user accounts, along with the associated password
@ -362,67 +373,81 @@ sub-directories:
'plaintext symbol, which will be used without encryption. This
may be useful for manually resetting a forgotten passwords.
* "active/" --- sub-directory for active assignments. A list of
active assignments is sent to a client tool when a student clicks
"Handin", based on the contents of this directory. The student
then selects from the list. The assignments are ordered in the
student's menu using `string<?', and the first assignment is the
default selection.
* "log" (or any other name that the 'log-file configuration option
specifies (if any), created if not present, appended otherwise)
--- records connections and actions, where each entry is of the
form
(id time-str msg-str)
[<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
name. Within each student sub-directory are directories for handin
attempts and successes. If a directory "ATTEMPT" exists, it
contains the most recent (unsuccessful) handin attempt.
Directories "SUCCESS-n" (where n counts from 0) contain successful
handins; the lowest numbered such directory represents the latest
handin.
* Active and inactive assignment directories (which you can put in a
nested directory for convenience, or specify a different absolute
directory), as specified by the configuration file using the
`active-dirs' and `inactive-dirs'. A list of active assignment
directories (the last path element in each specified path is used
as a label) is sent to the client tool when a student clicks
"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
"SUCCESS-n" directory. This is done only for files and
directories that are newer in "SUCCESS-n" than in the submission
root, other files and directories are left intact. If external
tools add new content to the student directory (eg, a "grade"
file, as described below) it will stay there. If the machine
file, as described below) it will stay there. If the machine
crashes or the server is stopped, the cleanup process might not
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.
Within a student directory, a file "handin.scm" (or some other
name if `default-file-name' is set) contains the actual
submission. A `checker' procedure can change this default file
Within a student directory, a "handin.scm" file (or some other
name if the `default-file-name' option is set) contains the actual
submission. A `checker' procedure can change this default file
name, and it can create additional files in an "ATTEMPT" directory
(to be copied by the cleanup process); see below on "checker.ss"
for more details.
(to be copied by the cleanup process); see below for more details
on "checker.ss".
For submissions from a normal DrScheme frame, a submission file
contains a copy of the student's definitions and interactions
windows. The file is in a binary format (to support non-text
windows. The file is in a binary format (to support non-text
code), and opening the file directly in DrScheme shows the
definitions part. To get both the definitions and interactions
definitions part. To get both the definitions and interactions
parts, the file can be parsed with `unpack-submission' from
"utils.ss" (see below).
To submit an assignment as a group, students use a concatenation
of usernames separated by "+" and any number of spaces (e.g.,
"user1+user2"). The same syntax ("user1+user2") is used for the
directory for shared submissions, and the usernames are always
sorted so that the directory name is deterministic. Multiple
directory for shared submissions, where the usernames are always
sorted so that directory names are deterministic. Multiple
submissions for a particular user in different groups will be
rejected.
* "inactive/" --- sub-directory for inactive assignments, used by
the HTTPS status web server.
Inactive assignment directories are used by the the HTTPS status
web server.
* "active/<assignment>/checker.ss" (optional) --- a module that
exports a `checker' function. This function receives two strings.
The first is a username list and the second is the submission as a
byte string. (See also `unpack-submission', etc. from "util.ss",
below.) To reject the submission, the `checker' function can
raise an exception; the exception message will be relayed back to
the student. The module is loaded when the current directory is
the main server directory, so it can read information from
"config.ss".
* "<active-dir>/<assignment>/checker.ss" (optional) --- a module
that exports a `checker' function. This function receives two
strings. The first is a username list and the second is the
submission as a byte string. (See also `unpack-submission',
etc. from "util.ss", below.) To reject the submission, the
`checker' function can raise an exception; the exception message
will be relayed back to the student. The module is loaded when
the current directory is the main server directory, so it can read
information from "config.ss".
The first argument is a list of usernames with at least one
username, and more than one if this is a joint submission (where
@ -430,16 +455,16 @@ sub-directories:
by "+").
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
value of the 'session-timeout configuration. The checker function
can change "handin", and it can create additional files in this
directory. (Extra files in the current directory will be
preserved as it is later renamed to "SUCCESS-0", and copied to the
submission's root ("active/<assignment>/<user/s>/"), etc.) To
hide generated files from the HTTPS status web server interface,
put the files in a subdirectory, which is preserved but hidden
from the status interface.
submission's root ("<active-assignment>/<username(s)>/"), etc.)
To hide generated files from the HTTPS status web server
interface, put the files in a subdirectory, it is preserved but
hidden from the status interface.
The checker should return a string, such as "handin.scm", to use
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
omit.
* "log" (or any other name that the 'log-file configuration option
specifies (if any), created if not present, appended otherwise)
--- records connections and actions, where each entry is of the
form
(id time-str msg-str)
[<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.
* "<[in]active-assignment>/<user(s)>/<filename>" (if submitted) ---
the most recent submission for <[in]active-assignment> by
<user(s)> where <filename> was returned by the checker (or the
value of the `default-file-name' configuration option if there's
no checker). If the submission is from multiple users, then
"<user(s)>" 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, but
will move up when the server performs a cleanup (or when
restarted).
* "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the
most recent submission for <assignment> by <user> where <filename>
was returned by the checker (or the value of the
`default-file-name' configuration option if there's no checker).
If the submission is from multiple users, then "<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(s)>/grade" (optional) ---
<user(s)>'s grade for <assignment>, to be reported by the HTTPS
status web server
* "[in]active/<assignment>/<user>/grade" (optional) --- <user>'s
grade for <assignment>, to be reported by the HTTPS status web
server
* "[in]active/<assignment>/solution*" --- the solution to the
* "<[in]active-assignment>/solution*" --- the solution to the
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
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,
but terminating the server is no worse than a network outage. (In
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
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
string and arguments. All this actually does, is arrange to print
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)
Control the timeout for this session. The timeout is initialized by
@ -848,13 +867,12 @@ Keywords for configuring `check:':
`current-value-printer' (see above).
* :coverage? -- collect coverage information when evaluating the
submission. This will
cause an error if some input is not covered. This check happens
after checker tests are run, but the information is collected and
stored before, so checker tests do not change the result. Also, you
can use the `!all-covered' procedure in the checker before other
tests, if you want that feedback earlier.
Does not work with non-textual submissions.
submission. This will cause an error if some input is not covered.
This check happens after checker tests are run, but the information
is collected and stored before, so checker tests do not change the
result. Also, you can use the `!all-covered' procedure in the
checker before other tests, if you want that feedback earlier. Does
not work with non-textual submissions.
Within the body of `check:', `users' and `submission' will be bound to
the checker arguments -- a (sorted) list of usernames and the

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

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

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

@ -15,6 +15,10 @@
(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)
(for-each (lambda (x) (write x port) (newline port)) xs)
(flush-output port))
@ -45,9 +49,8 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
(let ([name (success-dir n)])
(when (directory-exists? name)
@ -111,37 +114,29 @@
(define (cleanup-all-submissions)
(log-line "Cleaning up all submission directories")
(for-each (lambda (top)
(when (directory-exists? top)
(parameterize ([current-directory top])
(for-each (lambda (pset)
(when (directory-exists? pset) ; filter non-dirs
(parameterize ([current-directory pset])
(for-each (lambda (sub)
(when (directory-exists? sub)
(cleanup-submission sub)))
(directory-list)))))
(for-each (lambda (pset)
(when (directory-exists? pset) ; just in case
(parameterize ([current-directory pset])
(for-each (lambda (sub)
(when (directory-exists? sub) ; filter non-dirs
(cleanup-submission sub)))
(directory-list)))))
'("active" "inactive")))
(get-conf 'all-dirs)))
;; 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
;; active/inactive directories and run a cleanup if there was a change
(define connection-num 0)
(thread (lambda ()
(define last-active/inactive #f)
(define last-all-dirs #f)
(define last-connection-num #f)
(let loop ()
(let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
(when (>= n 0)
(let ([new (map (lambda (x)
(if (directory-exists? x)
(directory-list x)
null))
'("active" "inactive"))])
(if (equal? new last-active/inactive)
(let ([new (get-conf 'all-dirs)])
(if (equal? new last-all-dirs)
(begin (sleep 30) (loop (sub1 n)))
(begin (set! last-active/inactive new)
(begin (set! last-all-dirs new)
(set! last-connection-num #f))))))
(unless (equal? last-connection-num connection-num)
(cleanup-all-submissions)
@ -154,27 +149,28 @@
(with-output-to-file part
(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)
;; Note: users are always sorted
(define users (a-ref data 'usernames))
(define assignments (a-ref data 'assignments))
(define assignment (a-ref data 'assignment))
(define dirname
(apply string-append (car users)
(map (lambda (u) (string-append "+" u)) (cdr users))))
(define dirname (users->dirname users))
(define len #f)
(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)
(write+flush w 'ok)
(set! len (read r-safe))
(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))
(error 'handin
"max handin file size is ~s bytes, file to handin is too big (~s bytes)"
(get-conf 'max-upload) len))
(parameterize ([current-directory (build-path "active" assignment)])
(error* "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
(get-conf 'max-upload) len))
(parameterize ([current-directory (assignment<->dir assignment)])
(wait-for-lock dirname
(let ([dir (build-path (current-directory) dirname)])
(lambda () (cleanup-submission dir))))
@ -183,11 +179,11 @@
(for-each wait-for-lock users))
(write+flush w 'go)
(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)])
(unless (and (bytes? s) (= (bytes-length s) len))
(error 'handin "error uploading (got ~e, expected ~s bytes)"
(if (bytes? s) (bytes-length s) s) len))
(error* "error uploading (got ~e, expected ~s bytes)"
(if (bytes? s) (bytes-length s) s) len))
;; we have a submission, need to create a directory if needed, make
;; sure that no users submitted work with someone else
(unless (directory-exists? dirname)
@ -196,21 +192,20 @@
(for-each
(lambda (d)
(when (member d users)
(error 'handin
"bad submission: ~a has an existing submission (~a)"
d dir)))
(error* "bad submission: ~a has an existing submission (~a)"
d dir)))
(regexp-split #rx" *[+] *" (path->string dir))))
(directory-list))
(make-directory dirname))
(parameterize ([current-directory dirname]
[current-messenger
(case-lambda
[(msg) (write+flush w 'message msg)]
[(msg styles)
(if (eq? 'final styles)
(write+flush w 'message-final msg)
(begin (write+flush w 'message-box msg styles)
(read (make-limited-input-port r 50))))])])
[(msg) (write+flush w 'message msg)]
[(msg styles)
(if (eq? 'final styles)
(write+flush w 'message-final msg)
(begin (write+flush w 'message-box msg styles)
(read (make-limited-input-port r 50))))])])
;; Clear out old ATTEMPT, if any, and make a new one:
(when (directory-exists? ATTEMPT-DIR)
(delete-directory/files ATTEMPT-DIR))
@ -227,18 +222,18 @@
[(procedure? checker*) (values #f checker* #f)]
[(and (list? checker*) (= 3 (length checker*)))
(apply values checker*)]
[else (error 'handin-configuration
"bad checker value: ~e" checker*)]))
[else (error* "bad checker value: ~e" checker*)]))
(when pre
(let ([dir (current-directory)])
(with-handlers
([void (lambda (e)
(parameterize ([current-directory dir])
(unless (ormap
(lambda (d)
(and (directory-exists? d)
(regexp-match SUCCESS-RE d)))
(map path->string (directory-list)))
(unless (ormap (lambda (d)
(and (directory-exists? d)
(regexp-match
SUCCESS-RE
(path->string d))))
(directory-list))
(parameterize ([current-directory ".."])
(when (directory-exists? dirname)
(delete-directory/files dirname)))))
@ -265,23 +260,21 @@
(when post
(parameterize ([current-directory (success-dir 0)])
(post users s))))
(error 'handin "upload not confirmed: ~s" v)))))))))
(error* "upload not confirmed: ~s" v)))))))))
(define (retrieve-specific-submission data w)
;; Note: users are always sorted
(define users (a-ref data 'usernames))
(define assignments (a-ref data 'assignments))
(define assignment (a-ref data 'assignment))
(define dirname
(apply string-append (car users)
(map (lambda (u) (string-append "+" u)) (cdr users))))
(define submission-dir (build-path "active" assignment dirname))
(define dirname (users->dirname users))
(define submission-dir (build-path (assignment<->dir assignment) dirname))
(unless (member assignment assignments)
(error 'handin "not an active assignment: ~a" assignment))
(error* "not an active assignment: ~a" assignment))
(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)
(parameterize ([current-directory (build-path "active" assignment dirname)])
(parameterize ([current-directory submission-dir])
(define magics '(#"WXME" #"<<<MULTI-SUBMISSION-FILE>>>"))
(define mlen (apply max (map bytes-length magics)))
(define file
@ -307,7 +300,7 @@
(display "$" w)
(display (with-input-from-file file (lambda () (read-bytes len))) 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
(list (string->symbol username)) (list data)
(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"))
orig-custodian))
@ -333,10 +326,9 @@
[(list? field-re) (member value field-re)]
[(not field-re) #t]
[(eq? field-re '-) #t] ; -> hidden field, no check
[else (error 'handin "bad spec: field-regexp is ~e"
field-re)])
(error 'handin "bad ~a: \"~a\"~a" field-name value
(if field-desc (format "; need ~a" field-desc) ""))))
[else (error* "bad spec: field-regexp is ~e" field-re)])
(error* "bad ~a: \"~a\"~a" field-name value
(if field-desc (format "; need ~a" field-desc) ""))))
;; Utility for the next two functions: reconstruct a full list of
;; extra-fields from user-fields, using "" for hidden fields
@ -354,24 +346,24 @@
(define user-fields (a-ref data 'user-fields))
(define extra-fields (add-hidden-to-user-fields user-fields))
(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"
(get-conf 'user-desc))
;; Since we're going to use the username in paths, and + to split names:
(when (regexp-match #rx"[+/\\:|\"<>]" username)
(error 'handin "username must not contain one of the following: + / \\ : | \" < >"))
(error* "username must not contain these characters: + / \\ : | \" < >"))
(when (regexp-match
#rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
(string-foldcase username))
(error 'handin "username must not be a Windows special file name"))
(error* "username must not be a Windows special file name"))
(when (regexp-match #rx"^[ .]|[ .]$" username)
(error 'handin "username must not begin or end with a space or period"))
(error* "username must not begin or end with a space or period"))
(when (regexp-match #rx"^solution" username)
(error 'handin "the username prefix \"solution\" is reserved"))
(error* "the username prefix \"solution\" is reserved"))
(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)
(error 'handin "username already exists: `~a'" username))
(error* "username already exists: `~a'" username))
(for-each (lambda (str info)
(check-field str (cadr info) (car info) (caddr info)))
extra-fields (get-conf 'extra-fields))
@ -386,17 +378,16 @@
(define user-fields (a-ref data 'user-fields))
(define extra-fields (add-hidden-to-user-fields user-fields))
(unless (= 1 (length usernames))
(error 'handin "cannot change a password for multiple users: ~a"
usernames))
(error* "cannot change a password for multiple users: ~a" usernames))
;; the new data is the same as the old one for every empty string (includes
;; hidden fields)
(let ([new-data (map (lambda (old new) (if (equal? "" new) old new))
(car user-datas) (cons passwd extra-fields))])
(unless (or (get-conf 'allow-change-info)
(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))
(error 'handin "no fields changed: ~a" (car usernames)))
(error* "no fields changed: ~a" (car usernames)))
(for-each (lambda (str info)
(check-field str (cadr info) (car info) (caddr info)))
(cdr new-data) (get-conf 'extra-fields))
@ -407,7 +398,7 @@
(define (get-user-info data)
(define usernames (a-ref data 'usernames))
(unless (= 1 (length usernames))
(error 'handin "cannot get user-info for multiple users: ~a" usernames))
(error* "cannot get user-info for multiple users: ~a" usernames))
;; filter out hidden fields
(let ([all-data (cdar (a-ref data 'user-datas))])
(filter values (map (lambda (d f)
@ -426,7 +417,7 @@
(define (good? passwd)
(define (bad-password msg)
(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)]
[(and (list? passwd) (= 2 (length passwd))
(symbol? (car passwd)) (string? (cadr passwd)))
@ -513,8 +504,8 @@
(cons (get-conf 'master-password)
(map car user-datas)))))
(log-line "failed login: ~a" (a-ref data 'username/s))
(error 'handin "bad username or password for ~a"
(a-ref data 'username/s)))
(error* "bad username or password for ~a"
(a-ref data 'username/s)))
(log-line "login: ~a" usernames))
(case msg
[(change-user-info) (change-user-info data)]
@ -525,7 +516,7 @@
(write+flush w 'ok)) ; final confirmation for *all* actions
(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
(< (- (current-inexact-milliseconds) last-poll) poll-freq))
(set! last-poll (current-inexact-milliseconds))
(printf "polling...\n")
(let ([filetime (file-or-directory-modify-seconds config-file)])
(unless (and filetime (equal? filetime last-filetime))
(set! last-filetime filetime)
@ -28,7 +27,6 @@
(error 'get-conf
"could not read conf (~a)"
config-file))])
(printf "reading...\n")
(with-input-from-file config-file read)))
(set! config-cache (make-hash-table)))))
(hash-table-get config-cache key
@ -46,9 +44,12 @@
(define (rx s) (if (regexp? s) s (regexp s)))
(define (path p) (path->complete-path p server-dir))
(define (path/false p) (and p (path p)))
(define (path-list l) (map path l))
(define (config-default+translate which)
(case which
[(active-dirs) (values '() path-list )]
[(inactive-dirs) (values '() path-list )]
[(port-number) (values 7979 id )]
[(https-port-number) (values (add1 (get-conf 'port-number)) id )]
[(session-timeout) (values 300 id )]
@ -73,10 +74,32 @@
"a valid email address"))
id)]
;; 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)
(values (filter (lambda (f) (not (eq? '- (cadr f))))
(get-conf 'extra-fields))
#f)]
[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)]))
)

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

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