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

* New logging facility: simply use current-error-port as a logging output

Browse Source 
- uses a plain prefix-style log
  - does not save the log to log.ss (customization options will be coming up)
* Use that in the status servlet too
* Renamed `LOG' to `log-line'
  (it is now just printing to the current error port)
* Reformatted doc.txt, and some code
* Always use Content-Disposition, with `inline' for non-wxme files
* Moved run-status to private

svn: r4831
This commit is contained in:
Eli Barzilay 2006-11-13 01:24:34 +00:00
parent b8924dfbea
commit c19e157b48
6 changed files with 424 additions and 376 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -18,12 +18,12 @@ clients are properly customized, as described below).
The result, on the student's side, is a "Handin" button in DrScheme's The result, on the student's side, is a "Handin" button in DrScheme's
toolbar. Clicking the "Handin" button allows the student to type a toolbar. Clicking the "Handin" button allows the student to type a
password and upload the current content of the definitions and password and upload the current content of the definitions and
interactions window to the course instructor's server. The "File" menu interactions window to the course instructor's server. The "File"
is also extended with a "Manage..." menu item for managing a handin menu is also extended with a "Manage..." menu item for managing a
account (i.e., changing the password and other information, or handin account (i.e., changing the password and other information, or
creating a new account if the instructor configures the server to creating a new account if the instructor configures the server to
allow new accounts). Students can submit joint work by submitting with allow new accounts). Students can submit joint work by submitting
a concatenation of usernames separated by a "+". with a concatenation of usernames separated by a "+".
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. the student's submission before accepting it.
@ -94,8 +94,8 @@ To customize the client:
1. Rename (or make a copy of) the "handin-client" collection 1. Rename (or make a copy of) the "handin-client" collection
directory. The new name should describe your class uniquely. directory. The new name should describe your class uniquely.
For example, "uu-cpsc2010" is a good name for CPSC 2010 For example, "uu-cpsc2010" is a good name for CPSC 2010 at the
at the University of Utah. University of Utah.
2. Edit the first three definitions of "info.ss" in your renamed 2. Edit the first three definitions of "info.ss" in your renamed
client collection: client collection:
@ -122,9 +122,9 @@ To customize the client:
3. Replace "icon.png" in your renamed directory with a new 32x32 3. Replace "icon.png" in your renamed directory with a new 32x32
icon. This icon is displayed on startup with DrScheme's splash icon. This icon is displayed on startup with DrScheme's splash
screen, and it is included at half size on the "Handin" screen, and it is included at half size on the "Handin" button.
button. Again, choose a distinct icon for the benefit of Again, choose a distinct icon for the benefit of students who
students who install multiple handin tools. install multiple handin tools.
4. Replace "server-cert.pem" in your renamed directory with a 4. Replace "server-cert.pem" in your renamed directory with a
server certificate. The file "server-cert.pem" in server certificate. The file "server-cert.pem" in
@ -159,9 +159,10 @@ sub-directories:
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
Whereas "server-cert.pem" gets distributed to students with the "server-cert.pem". Whereas "server-cert.pem" gets distributed to
handin client, "private-key.pem" is kept private. students with the 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
@ -314,12 +315,12 @@ sub-directories:
system file: system file:
foo:wRzN1u5q2SqRD:1203:1203:L.E. Foo:/home/foo:/bin/tcsh foo:wRzN1u5q2SqRD:1203:1203:L.E. Foo:/home/foo:/bin/tcsh
bar:$1$dKlU0OkJ$t63NU/eTzKz:1205:1205:Bar Z. Lie:/home/bar:/bin/bash bar:$1$dKlU0OkJ$t63TzKz:1205:1205:Bar Z. Lie:/home/bar:/bin/bash
you can create this "users.ss" file: you can create this "users.ss" file:
((foo ((unix "wRzN1u5q2SqRD") "L.E. Foo" "?")) ((foo ((unix "wRzN1u5q2SqRD") "L.E. Foo" "?"))
(bar ((unix "$1$dKlU0OkJ$t63NU/eTzKz") "Bar Z. Lie" "?"))) (bar ((unix "$1$dKlU0OkJ$t63TzKz") "Bar Z. Lie" "?")))
which can be combined with this setting for 'extra-fields in your which can be combined with this setting for 'extra-fields in your
"config.ss": "config.ss":
@ -477,7 +478,9 @@ sub-directories:
The server can be run within either MzScheme or MrEd, but "utils.ss" The server can be run within either MzScheme or MrEd, but "utils.ss"
requires MrEd (which means that `checker' modules will likely require requires MrEd (which means that `checker' modules will likely require
the server to run under MrEd). the server to run under MrEd). It is best to use MrEd3m so memory
accounting is possible and the server will be protected from memory
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
@ -485,16 +488,16 @@ 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 the set of active assignments), stop it and restart it.
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 "cancel" problems and timeouts. The client-side tool always provides a
button for any network transaction. For handins, "cancel" is "cancel" button for any network transaction. For handins, "cancel" is
guaranteed to work up to the point that the client sends a "commit" guaranteed to work up to the point that the client sends a "commit"
command; this command is sent only after the server is ready to record command; this command is sent only after the server is ready to record
the submission (having run it through the checker, if any), but before the submission (having run it through the checker, if any), but before
renaming "ATTEMPT". Also, the server responds to a commit with "ok" renaming "ATTEMPT". Also, the server responds to a commit with "ok"
only after it has written the file. Thus, when the client-side tool only after it has written the file. Thus, when the client-side tool
reports that the handin was successful, the report is reports that the handin was successful, the report is reliable.
reliable. Meanwhile, the tool can also report successful cancels most Meanwhile, the tool can also report successful cancels most of the
of the time. In the (normally brief) time between a commit and an "ok" time. In the (normally brief) time between a commit and an "ok"
response, the tool gives the student a suitable warning that the response, the tool gives the student a suitable warning that the
cancel is unreliable. cancel is unreliable.
@ -522,14 +525,15 @@ Checker Utilities
The _utils.ss_ module provides utilities helpful in implementing The _utils.ss_ module provides utilities helpful in implementing
`checker' functions: `checker' functions:
> (unpack-submission bytes) - returns two text% objects corresponding > (unpack-submission bytes)
to the submitted definitions and interactions windows. Returns two text% objects corresponding to the submitted definitions
and interactions windows.
> (make-evaluator language teachpack-paths program-port) - returns a > (make-evaluator language teachpack-paths program-port)
function of one required argument for evaluating expressions in the Returns a function of one required argument for evaluating
designated language, and loading teachpacks that are specified in expressions in the designated language, and loading teachpacks that
`teachpack-paths'. The `program-port' is an input port that are specified in `teachpack-paths'. The `program-port' is an input
produces the content of the definitions window; use port that produces the content of the definitions window; use
`(open-input-string "")' for an empty definitions window. `(open-input-string "")' for an empty definitions window.
The `language' can be: The `language' can be:
@ -557,114 +561,118 @@ The _utils.ss_ module provides utilities helpful in implementing
that retrieve additional information. Currently, only that retrieve additional information. Currently, only
'execute-counts is used (see below). 'execute-counts is used (see below).
> (make-evaluator/submission language teachpack-paths bytes) - like > (make-evaluator/submission language teachpack-paths bytes)
`make-evaluator', but the definitions content is supplied as a Like `make-evaluator', but the definitions content is supplied as a
submission byte string. The byte string is opened for reading, with submission byte string. The byte string is opened for reading, with
line-counting enabled. line-counting enabled.
> (call-with-evaluator language teachpack-paths program-port proc) - > (call-with-evaluator language teachpack-paths program-port proc)
calls `proc' with an evaluator for the given language, teachpack Calls `proc' with an evaluator for the given language, teachpack
paths, and initial definition content as supplied by a port. It also paths, and initial definition content as supplied by a port. It
sets the current error-value print handler to print values in a way also sets the current error-value print handler to print values in a
suitable for `lang', it initializes `current-run-status' with way suitable for `lang', it initializes `current-run-status' with
"executing your code", and it catches all exceptions to re-raise "executing your code", and it catches all exceptions to re-raise
them in a form suitable as a submission error. them in a form suitable as a submission error.
> (call-with-evaluator/submission language teachpack-paths bytes proc) - > (call-with-evaluator/submission language teachpack-paths bytes proc)
like `call-with-evaluator', but the definitions content is supplied Like `call-with-evaluator', but the definitions content is supplied
as a submission string. The byte string is opened for reading, as a submission string. The byte string is opened for reading, with
with line-counting enabled. line-counting enabled.
> (evaluate-all source input-port eval)
Like `load' on an input port.
> (evaluate-all source input-port eval) - like `load' on an input > (evaluate-submission bytes eval)
port. Like `load' on a non-test-suite submission byte string.
> (evaluate-submission bytes eval) - like `load' on a non-test-suite > coverage-enabled
submission byte string. Parameter that controls whether coverage testing is enabled. If it
set to true, the errortrace collection will be used to collect
coverage information during evaluation of the submission, this
information is collected before additional checker-evaluations. To
retrieve the collected information, apply the evaluation function
with a second argument of 'execute-counts (the first argument will
be ignored). The resulting value is the same as the result of
errortrace's `get-execute-counts', with all non-submission entries
filtered out.
> (check-proc eval expect-v compare-proc proc-name arg ...)
> coverage-enabled - parameter that controls whether coverage testing Calls the function named `proc-name' using the evaluator `eval',
is enabled. If it set to true, the errortrace collection will be giving it the (unquoted) arguments `arg'... Let `result-v' be the
used to collect coverage information during evaluation of the result of the call; unless `(compare-proc result-v expect-v)' is
submission, this information is collected before additional true, an exception is raised.
checker-evaluations. To retrieve the collected information, apply
the evaluation function with a second argument of 'execute-counts
(the first argument will be ignored). The resulting value is the
same as the result of errortrace's `get-execute-counts', with all
non-submission entries filtered out.
> (check-proc eval expect-v compare-proc proc-name arg ...) - calls
the function named `proc-name' using the evaluator `eval', giving it
the (unquoted) arguments `arg'... Let `result-v' be the result of
the call; unless `(compare-proc result-v expect-v)' is true, an
exception is raised.
Every exception or result mismatch during the call to `check-proc' Every exception or result mismatch during the call to `check-proc'
phrased suitably for the handin client. phrased suitably for the handin client.
> (check-defined eval name) - checks whether `name' is defined in the > (check-defined eval name)
evaluator `eval', and raises an error if not (suitably phrased for Checks whether `name' is defined in the evaluator `eval', and raises
the handin client). If it is defined as non-syntax, its value is an error if not (suitably phrased for the handin client). If it is
returned. Warning: in the beginner language level, procedure defined as non-syntax, its value is returned. Warning: in the
definitions are bound as syntax. beginner language level, procedure definitions are bound as syntax.
> (look-for-tests text name n) - inspects the given text% object to > (look-for-tests text name n)
determine whether it contains at least `n' tests for the function Inspects the given text% object to determine whether it contains at
`name'. The tests must be top-level expressions. least `n' tests for the function `name'. The tests must be
top-level expressions.
> (user-construct eval name arg ...) - like `check-proc', but with no > (user-construct eval name arg ...)
result checking. This function is often useful for calling a Like `check-proc', but with no result checking. This function is
student-defined constructor. often useful for calling a student-defined constructor.
> test-history-enabled
Parameter that controls how run-time errors are reported to the
handin client. If the parameter's value is true, then the complete
sequence of tested expressions is reported to the handin client for
any test failure. Set this parameter to true when testing programs
that use state.
> test-history-enabled - parameter that controls how run-time errors > (message string [styles])
are reported to the handin client. If the parameter's value is true, If given only a string, this string will be shown on the client's
then the complete sequence of tested expressions is reported to the submission dialog; if `styles' is also given, it can be the symbol
handin client for any test failure. Set this parameter to true when 'final, which will be used as the text on the handin dialog after a
testing programs that use state. successful submission instead of "Handin successful." (useful for
submissions that were saved, but had problems); finally, `styles'
can be used as a list of styles for a `message-box' dialog on the
client side, and the resulting value is returned as the result of
`message'. You can use that to send warnings to the student and
wait for confirmation.
> (message string [styles]) - if given only a string, this string will > (current-run-status string-or-#f)
be shown on the client's submission dialog; if `styles' is also Registers information about the current actions of the checker, in
given, it can be the symbol 'final, which will be used as the text case the session is terminated due to excessive memory consumption.
on the handin dialog after a successful submission instead of For example, a checker might set the status to indicate which
"Handin successful." (useful for submissions that were saved, but instructor-supplied test was being executed when the session ran out
had problems); finally, `styles' can be used as a list of styles for of memory. This status is only used when per-session memory limits
a `message-box' dialog on the client side, and the resulting value are supported (i.e., under MrEd3m or MzScheme3m with memory
is returned as the result of `message'. You can use that to send accounting), but in both cases, a string value will also be passed
warnings to the student and wait for confirmation. on to `message' above.
> (current-run-status string-or-#f) - registers information about the > (current-value-printer proc)
current actions of the checker, in case the session is terminated A parameter that controls how values are printed, a procedure that
due to excessive memory consumption. For example, a checker might expects a Scheme value and returns a string representation for it.
set the status to indicate which instructor-supplied test was being The default value printer uses pretty-print, with DrScheme-like
executed when the session ran out of memory. This status is only settings.
used when per-session memory limits are supported (i.e., under
MrEd3m or MzScheme3m with memory accounting), but in both cases, a
string value will also be passed on to `message' above.
> (current-value-printer proc) - a parameter that controls how values > (reraise-exn-as-submission-problem thunk)
are printed, a procedure that expects a Scheme value and returns a Calls thunk in a context that catches exceptions and re-raises them
string representation for it. The default value printer uses in a form suitable as a submission error.
pretty-print, with DrScheme-like settings.
> (reraise-exn-as-submission-problem thunk) - calls thunk in a context > (log-line fmt args ...)
that catches exceptions and re-raises them in a form suitable as a Produces a line in the server log file, using the given format
submission error. 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.
> (timeout-control msg)
> (LOG fmt args ...) - produces a line in the server log file, using Control the timeout for this session. The timeout is initialized by
the given format string and arguments. the value of the 'session-timeout configuration entry, and the
checker can use this procedure to further control it: if msg is
> (timeout-control msg) - control the timeout for this session. The 'reset the timeout is reset to 'session-timeout seconds; if msg is a
timeout is initialized by the value of the 'session-timeout number the timeout will be set to that many seconds in the future.
configuration entry, and the checker can use this procedure to The timeout can be completely disabled by (timeout-control #f).
further control it: if msg is 'reset the timeout is reset to (Note that before the checker is used (after the pre-checker, if
'session-timeout seconds; if msg is a number the timeout will be set specified), the timer will be reset to the 'session-timeout value.)
to that many seconds in the future. The timeout can be completely
disabled by (timeout-control #f). (Note that before the checker is
used (after the pre-checker, if specified), the timer will be reset
to the 'session-timeout value.)
Extra Checker Utilities Extra Checker Utilities
@ -780,10 +788,10 @@ Keywords for configuring `check:':
additional tests). It can be a plain string which will be used as additional tests). It can be a plain string which will be used as
the error message, or a string with single a "~a" (or "~e", "~s", the error message, or a string with single a "~a" (or "~e", "~s",
"~v") that will be used as a format string with the actual error "~v") that will be used as a format string with the actual error
message. The default is "Error in your code --\n~a". Examples of message. The default is "Error in your code --\n~a". Useful
these: examples of these messages:
"there is an error in your program, hit \"Run\" and debug your code" "There is an error in your program, hit \"Run\" to debug"
"There is an error in your program:\n----\n~a\n----\n "There is an error in your program:\n----\n~a\n----\n
Hit \"Run\" and debug your code." Hit \"Run\" and debug your code."
@ -798,8 +806,10 @@ Keywords for configuring `check:':
(message (string-append (message (string-append
"You have an error in your program -- please hit" "You have an error in your program -- please hit"
" \"Run\" and debug your code.\n" " \"Run\" and debug your code.\n"
"Email the course staff if you think your code is fine.\n" "Email the course staff if you think your code is"
"(The submission has been saved but marked as erroneous.)") " fine.\n"
"(The submission has been saved but marked as"
" erroneous.)")
'(ok)) '(ok))
(message "Handin saved as erroneous." 'final)) (message "Handin saved as erroneous." 'final))
@ -841,7 +851,7 @@ value from the submission code.
(file-size "hw.scm") (file-size "hw.scm")
(file-or-directory-modify-seconds "hw.scm"))) (file-or-directory-modify-seconds "hw.scm")))
(timeout-control 'disable) (timeout-control 'disable)
(LOG "Sending a receipt: ~a" info) (log-line "Sending a receipt: ~a" info)
(send-mail-message (send-mail-message
"course-staff@university.edu" "course-staff@university.edu"
"Submission Receipt" "Submission Receipt"

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

@ -8,12 +8,12 @@
(lib "string.ss") (lib "string.ss")
"private/md5.ss" "private/md5.ss"
"private/lock.ss" "private/lock.ss"
"web-status-server.ss" "private/logger.ss"
"run-status.ss") "private/run-status.ss"
"web-status-server.ss")
(define log-port (open-output-file "log.ss" 'append)) ;; !!! (define log-port (open-output-file "log.ss" 'append))
(install-logger-port)
(define current-session (make-parameter 0))
(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)
@ -29,19 +29,6 @@
[(pair? default) (car default)] [(pair? default) (car default)]
[else (error (alist-name alist) "no value for `~s'" key)])) [else (error (alist-name alist) "no value for `~s'" key)]))
(provide LOG)
(define (LOG str . args)
;; Assemble log into into a single string, to make
;; interleaved log lines unlikely:
(let ([line
(format "(~a ~s ~s)\n"
(current-session)
(parameterize ([date-display-format 'iso-8601])
(date->string (seconds->date (current-seconds)) #t))
(apply format str args))])
(display line log-port)
(flush-output log-port)))
(define server-dir (current-directory)) (define server-dir (current-directory))
(define config-file (build-path server-dir "config.ss")) (define config-file (build-path server-dir "config.ss"))
@ -118,7 +105,7 @@
[dir (and (pair? dir) (car dir))]) [dir (and (pair? dir) (car dir))])
(when dir (when dir
(unless (member dir SUCCESS-GOOD) (unless (member dir SUCCESS-GOOD)
(LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a" (log-line "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
(build-path (current-directory) dir))) (build-path (current-directory) dir)))
;; We have a submission directory -- copy all newer things (extra ;; We have a submission directory -- copy all newer things (extra
;; things that exist in the main submission directory but not in ;; things that exist in the main submission directory but not in
@ -148,14 +135,14 @@
;; exclusive access to the directory contents. ;; exclusive access to the directory contents.
(with-handlers ([void (with-handlers ([void
(lambda (e) (lambda (e)
(LOG "*** ERROR DURING (cleanup-submission ~s) : ~a" (log-line "*** ERROR DURING (cleanup-submission ~s) : ~a"
dir (if (exn? e) (exn-message e) e)))]) dir (if (exn? e) (exn-message e) e)))])
(when (directory-exists? dir) ; submissions can fail before mkdir (when (directory-exists? dir) ; submissions can fail before mkdir
(parameterize ([current-directory dir]) (parameterize ([current-directory dir])
(call-with-semaphore cleanup-sema cleanup-submission-body))))) (call-with-semaphore cleanup-sema cleanup-submission-body)))))
(define (cleanup-all-submissions) (define (cleanup-all-submissions)
(LOG "Cleaning up all submission directories") (log-line "Cleaning up all submission directories")
(for-each (lambda (top) (for-each (lambda (top)
(when (directory-exists? top) (when (directory-exists? top)
(parameterize ([current-directory top]) (parameterize ([current-directory top])
@ -210,7 +197,7 @@
(define len #f) (define len #f)
(unless (member assignment assignments) (unless (member assignment assignments)
(error 'handin "not an active assignment: ~a" assignment)) (error 'handin "not an active assignment: ~a" assignment))
(LOG "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))
@ -262,7 +249,7 @@
(make-directory ATTEMPT-DIR) (make-directory ATTEMPT-DIR)
(save-submission s (build-path ATTEMPT-DIR "handin")) (save-submission s (build-path ATTEMPT-DIR "handin"))
(timeout-control 'reset) (timeout-control 'reset)
(LOG "checking ~a for ~a" assignment users) (log-line "checking ~a for ~a" assignment users)
(let* ([checker* (path->complete-path (build-path 'up "checker.ss"))] (let* ([checker* (path->complete-path (build-path 'up "checker.ss"))]
[checker* (and (file-exists? checker*) [checker* (and (file-exists? checker*)
(parameterize ([current-directory server-dir]) (parameterize ([current-directory server-dir])
@ -298,7 +285,7 @@
(let ([v (read (make-limited-input-port r 50))]) (let ([v (read (make-limited-input-port r 50))])
(if (eq? v 'check) (if (eq? v 'check)
(begin (begin
(LOG "saving ~a for ~a" assignment users) (log-line "saving ~a for ~a" assignment users)
(parameterize ([current-directory ATTEMPT-DIR]) (parameterize ([current-directory ATTEMPT-DIR])
(cond [part (unless (equal? part "handin") (cond [part (unless (equal? part "handin")
(rename-file-or-directory "handin" part))] (rename-file-or-directory "handin" part))]
@ -325,7 +312,7 @@
(error 'handin "not an active assignment: ~a" assignment)) (error 'handin "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 'handin "no ~a submission directory for ~a" assignment users))
(LOG "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 (build-path "active" assignment dirname)])
(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)))
@ -419,7 +406,7 @@
(lambda (str info) (check-field str (cadr info) (car info) (caddr info))) (lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
extra-fields EXTRA-FIELDS) extra-fields EXTRA-FIELDS)
(wait-for-lock "+newuser+") (wait-for-lock "+newuser+")
(LOG "create user: ~a" username) (log-line "create user: ~a" username)
(put-user-data username (cons passwd extra-fields))) (put-user-data username (cons passwd extra-fields)))
(define (change-user-info data) (define (change-user-info data)
@ -442,7 +429,7 @@
(for-each (for-each
(lambda (str info) (check-field str (cadr info) (car info) (caddr info))) (lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
(cdr new-data) EXTRA-FIELDS) (cdr new-data) EXTRA-FIELDS)
(LOG "change info for ~a ~s -> ~s" (log-line "change info for ~a ~s -> ~s"
(car usernames) (car user-datas) new-data) (car usernames) (car user-datas) new-data)
(put-user-data (car usernames) new-data))) (put-user-data (car usernames) new-data)))
@ -466,7 +453,7 @@
(define (has-password? raw md5 passwords) (define (has-password? raw md5 passwords)
(define (good? passwd) (define (good? passwd)
(define (bad-password msg) (define (bad-password msg)
(LOG "ERROR: ~a -- ~s" msg passwd) (log-line "ERROR: ~a -- ~s" msg passwd)
(error 'handin "bad password in user database")) (error 'handin "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))
@ -552,10 +539,10 @@
(a-ref data 'raw-password) (a-ref data 'raw-password)
(a-ref data 'password) (a-ref data 'password)
(cons MASTER-PASSWD (map car user-datas))))) (cons MASTER-PASSWD (map car user-datas)))))
(LOG "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 'handin "bad username or password for ~a"
(a-ref data 'username/s))) (a-ref data 'username/s)))
(LOG "login: ~a" usernames)) (log-line "login: ~a" usernames))
(case msg (case msg
[(change-user-info) (change-user-info data)] [(change-user-info) (change-user-info data)]
[(save-submission) (accept-specific-submission data r r-safe w)] [(save-submission) (accept-specific-submission data r r-safe w)]
@ -574,7 +561,7 @@
(define current-timeout-control (make-parameter #f)) (define current-timeout-control (make-parameter #f))
(provide timeout-control) (provide timeout-control)
(define (timeout-control msg) (define (timeout-control msg)
(LOG "timeout-control: ~s" msg) (log-line "timeout-control: ~s" msg)
((current-timeout-control) msg)) ((current-timeout-control) msg))
(define (with-watcher w proc) (define (with-watcher w proc)
@ -595,7 +582,7 @@
(with-handlers ([exn:fail:unsupported? (with-handlers ([exn:fail:unsupported?
(lambda (x) (lambda (x)
(set! no-limit-warning? #t) (set! no-limit-warning? #t)
(LOG "WARNING: per-session memory limit not supported by MrEd"))]) (log-line "WARNING: per-session memory limit not supported by MrEd"))])
(custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust))) (custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust)))
(let* ([watcher (let* ([watcher
(parameterize ([current-custodian orig-custodian]) (parameterize ([current-custodian orig-custodian])
@ -609,7 +596,7 @@
[status (if status [status (if status
(format " while ~a" status) (format " while ~a" status)
"")]) "")])
(LOG "session killed ~a~a" (log-line "session killed ~a~a"
(if timed-out? "(timeout) " "(memory)") (if timed-out? "(timeout) " "(memory)")
status) status)
(write+flush (write+flush
@ -627,7 +614,7 @@
(loop #t)] (loop #t)]
[else [else
(collect-garbage) (collect-garbage)
(LOG "running ~a ~a" (log-line "running ~a ~a"
(current-memory-use session-cust) (current-memory-use session-cust)
(if no-limit-warning? (if no-limit-warning?
"(total)" "(total)"
@ -652,26 +639,24 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(LOG "server started ------------------------------") (log-line "server started ------------------------------")
(define stop-status (serve-status HTTPS-PORT-NUMBER get-config)) (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 (lambda (msg exn) (log-line msg))])
(lambda (msg exn)
(LOG msg))])
(run-server (run-server
PORT-NUMBER PORT-NUMBER
(lambda (r w) (lambda (r w)
(set! connection-num (add1 connection-num)) (set! connection-num (add1 connection-num))
(when ((current-memory-use) . > . SESSION-MEMORY-LIMIT) (when ((current-memory-use) . > . SESSION-MEMORY-LIMIT)
(collect-garbage)) (collect-garbage))
(parameterize ([current-session (begin (parameterize ([current-session
(set! session-count (add1 session-count)) (begin (set! session-count (add1 session-count))
session-count)]) session-count)])
(let-values ([(here there) (ssl-addresses r)]) (let-values ([(here there) (ssl-addresses r)])
(LOG "connect from ~a" there)) (log-line "connect from ~a" there))
(with-watcher (with-watcher
w w
(lambda (kill-watcher) (lambda (kill-watcher)
@ -684,7 +669,7 @@
(exn-message exn) (exn-message exn)
(format "~e" exn))]) (format "~e" exn))])
(kill-watcher) (kill-watcher)
(LOG "ERROR: ~a" msg) (log-line "ERROR: ~a" msg)
(write+flush w msg) (write+flush w msg)
;; see note on close-output-port below ;; see note on close-output-port below
(close-output-port w)))]) (close-output-port w)))])
@ -693,14 +678,14 @@
(write+flush w 'ver1) (write+flush w 'ver1)
(error 'handin "unknown protocol: ~s" protocol))) (error 'handin "unknown protocol: ~s" protocol)))
(handle-connection r r-safe w) (handle-connection r r-safe w)
(LOG "normal exit") (log-line "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
;; here due to a deficiency in the SLL binding. ;; here due to a deficiency in the SLL binding. The problem is
;; The problem is that a custodian shutdown of w is harsher ;; that a custodian shutdown of w is harsher for SSL output
;; for SSL output than a normal close. A normal close ;; than a normal close. A normal close flushes an internal
;; flushes an internal buffer that's not supposed to exist, while ;; buffer that's not supposed to exist, while the shutdown
;; the shutdown gives up immediately. ;; gives up immediately.
(close-output-port w))))))) (close-output-port w)))))))
#f ; `with-watcher' handles our timeouts #f ; `with-watcher' handles our timeouts
(lambda (exn) (lambda (exn)

51
collects/handin-server/private/logger.ss Normal file
View File

@ -0,0 +1,51 @@
(module logger mzscheme
(require (lib "date.ss"))
(provide current-session)
(define current-session (make-parameter #f))
;; A convenient function to print log lines (which really just assembles a
;; string to print in one shot, and flushes the output)
(provide log-line)
(define (log-line fmt . args)
(let ([line (format "~a\n" (apply format fmt args))])
(display line (current-error-port))))
(define (prefix)
(parameterize ([date-display-format 'iso-8601])
(format "[~a|~a] "
(or (current-session) '-)
(date->string (seconds->date (current-seconds)) #t))))
;; Implement a logger by capturing current-error-port and printing a prefix,
;; provide a function to install this port
(define (make-logger-port stderr)
(define prompt? #t)
(define sema (make-semaphore 1))
(make-output-port
'logger-output
stderr
(lambda (buf start end imm? break?)
(dynamic-wind
(lambda () (semaphore-wait sema))
(lambda ()
(if (= start end)
(begin (flush-output stderr) 0)
(let ([nl (regexp-match-positions #rx#"\n" buf start end)])
;; may be problematic if this hangs...
(when prompt? (display (prefix) stderr) (set! prompt? #f))
(if (not nl)
(write-bytes-avail* buf stderr start end)
(let* ([nl (cdar nl)]
[l (write-bytes-avail* buf stderr start nl)])
(when (= l (- nl start))
;; pre-newline part written
(flush-output stderr) (set! prompt? #t))
l)))))
(lambda () (semaphore-post sema))))
(lambda () (close-output-port stderr))))
;; Install this wrapper on the current error port
(provide install-logger-port)
(define (install-logger-port)
(current-error-port (make-logger-port (current-error-port)))))

0
collects/handin-server/run-status.ss → collects/handin-server/private/run-status.ss
View File

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

@ -6,6 +6,7 @@
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "servlet-sig.ss" "web-server") (lib "servlet-sig.ss" "web-server")
(lib "response-structs.ss" "web-server") (lib "response-structs.ss" "web-server")
(lib "logger.ss" "handin-server" "private")
(lib "md5.ss" "handin-server" "private") (lib "md5.ss" "handin-server" "private")
(lib "uri-codec.ss" "net")) (lib "uri-codec.ss" "net"))
@ -151,6 +152,7 @@
(define (one-status-page status for-handin) (define (one-status-page status for-handin)
(let ([user (get-status status 'user (lambda () "???"))]) (let ([user (get-status status 'user (lambda () "???"))])
(log-line "Status access: ~s" user)
(let ([next (let ([next
(send/suspend (send/suspend
(lambda (k) (lambda (k)
@ -183,6 +185,7 @@
(string<? a b)) (string<? a b))
(string<? a b)))))] (string<? a b)))))]
[user (get-status status 'user (lambda () "???"))]) [user (get-status status 'user (lambda () "???"))])
(log-line "Status access: ~s" user)
(let ([next (let ([next
(send/suspend (send/suspend
(lambda (k) (lambda (k)
@ -229,7 +232,8 @@
(or (check file `(* ,who *)) (or (check file `(* ,who *))
(check file `(* #rx"^solution")) (check file `(* #rx"^solution"))
(check file `(* #rx"^solution" *)) (check file `(* #rx"^solution" *))
(error "Boom!"))) (error "Boom!"))
(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))))]
@ -240,13 +244,12 @@
[wxme? #"application/data"] [wxme? #"application/data"]
[else #"text/plain"]) [else #"text/plain"])
`((Content-Length . ,(number->string (bytes-length data))) `((Content-Length . ,(number->string (bytes-length data)))
,@(if wxme? (Content-Disposition
`((Content-Disposition . ,(format "~a; filename=~s"
. (if wxme? "attachment" "inline")
,(format "attachment; filename=~s" (let-values ([(base name dir?)
(let-values ([(base name dir?) (split-path file)]) (split-path file)])
(path->string name))))) (path->string name)))))
'()))
(list data))))) (list data)))))
(define (status-page status for-handin) (define (status-page status for-handin)

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

@ -2,12 +2,12 @@
(require (lib "class.ss") (require (lib "class.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "posn.ss" "lang") (lib "posn.ss" "lang")
"run-status.ss" "private/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") (lib "string.ss")
(only "handin-server.ss" LOG timeout-control)) (only "handin-server.ss" timeout-control))
(provide unpack-submission (provide unpack-submission
@ -34,7 +34,6 @@
user-construct user-construct
test-history-enabled test-history-enabled
LOG
timeout-control) timeout-control)
(define (unpack-submission str) (define (unpack-submission str)