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

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

@ -6,24 +6,24 @@ instructor for accepting homework assignments and reporting on
submitted assignments.
The "handin-client" directory contains a client to be customized then
re-distributed to students in the course. The customized client will
re-distributed to students in the course. The customized client will
embed a particular hostname and port where the server is running, as
well as a server certificate.
With a customized client, students simply install a ".plt" file --- so
there's no futzing with configuration dialogs and certificates. A
there's no futzing with configuration dialogs and certificates. A
student can install any number of clients at once (assuming that the
clients are properly customized, as described below).
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
interactions window to the course instructor's server. The "File" menu
is also extended with a "Manage..." menu item for managing a handin
account (i.e., changing the password and other information, or
interactions window to the course instructor's server. The "File"
menu is also extended with a "Manage..." menu item for managing a
handin account (i.e., changing the password and other information, or
creating a new account if the instructor configures the server to
allow new accounts). Students can submit joint work by submitting with
a concatenation of usernames separated by a "+".
allow new accounts). Students can submit joint work by submitting
with a concatenation of usernames separated by a "+".
On the instructor's side, the handin server can be configured to check
the student's submission before accepting it.
@ -93,16 +93,16 @@ Client Customization
To customize the client:
1. Rename (or make a copy of) the "handin-client" collection
directory. The new name should describe your class uniquely.
For example, "uu-cpsc2010" is a good name for CPSC 2010
at the University of Utah.
directory. The new name should describe your class uniquely.
For example, "uu-cpsc2010" is a good name for CPSC 2010 at the
University of Utah.
2. Edit the first three definitions of "info.ss" in your renamed
client collection:
* For `name', choose a name for the handin tool as it will
appear in DrScheme's interface (e.g., the "XXX" for the
"Manage XXX Handin Account..." menu item). Again, make the
"Manage XXX Handin Account..." menu item). Again, make the
name specific to the course, in case a student installs
multiple handin tools. Do not use "Handin" as the last part
of the name, since "Handin" is always added for button and
@ -121,17 +121,17 @@ To customize the client:
menu that opens a (course-specific) web page.
3. Replace "icon.png" in your renamed directory with a new 32x32
icon. This icon is displayed on startup with DrScheme's splash
screen, and it is included at half size on the "Handin"
button. Again, choose a distinct icon for the benefit of
students who install multiple handin tools.
icon. This icon is displayed on startup with DrScheme's splash
screen, and it is included at half size on the "Handin" button.
Again, choose a distinct icon for the benefit of students who
install multiple handin tools.
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
"handin-client" collection is ok for testing, but the point of
this certificate is to make handins secure, so you should
generate a new (self-certifying) certificate and keep its key
private. (See server setup, below.)
private. (See server setup, below.)
5. Run
mzc --collection-plt <name>.plt <name>
@ -139,9 +139,9 @@ To customize the client:
(i.e., whatever you changed "handin-client" to).
6. Distribute <name>.plt to students for installation into their
copies of DrScheme. The students need not have access to the
copies of DrScheme. The students need not have access to the
DrScheme installation directory; the tool will be installed on
the filesystem in the student's personal space. If you want to
the filesystem in the student's personal space. If you want to
install it once on a shared installation, use setup-plt with the
--all-users flag.
@ -150,18 +150,19 @@ Server Setup
============================================
The server must be run from a directory that is specially prepared to
host the server. This directory contains the following files and
host the server. This directory contains the following files and
sub-directories:
* "server-cert.pem" --- the server's certificate. To create a
* "server-cert.pem" --- the server's certificate. To create a
certificate and key with openssl:
openssl req -new -nodes -x509 -days 365 -out server-cert.pem
-keyout private-key.pem
openssl req -new -nodes -x509 -days 365 -out server-cert.pem
-keyout private-key.pem
* "private-key.pem" --- the private key to go with "server-cert.pem".
Whereas "server-cert.pem" gets distributed to students with the
handin client, "private-key.pem" is kept private.
* "private-key.pem" --- the private key to go with
"server-cert.pem". Whereas "server-cert.pem" gets distributed to
students with the handin client, "private-key.pem" is kept
private.
* "config.ss" (optional) --- configuration options. The file format
is
@ -280,7 +281,7 @@ sub-directories:
the list of user accounts, along with the associated password
(actually the MD5 hash of the password), and extra string fields
as specified by the 'extra-fields configuration entry (in the same
order). The file format is
order). The file format is
((<username-sym> (<pw-md5-str> <extra-field> ...))
...)
@ -291,13 +292,13 @@ sub-directories:
...)
Username that begin with "solution" are special. They are used by
the HTTPS status server. Independent of the 'user-regexp and
the HTTPS status server. Independent of the 'user-regexp and
'username-case-sensitive? configuration items, usernames are not
allowed to contain characters that are illegal in Windows
pathnames, they cannot end or begin in spaces or periods.
If the 'allow-new-users configuration allows new users, the
"users.ss" file can be updated by the server with new users. It
"users.ss" file can be updated by the server with new users. It
can always be updated by the server to change passwords.
If you have access to a standard Unix password file (from
@ -314,12 +315,12 @@ sub-directories:
system file:
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:
((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
"config.ss":
@ -477,34 +478,36 @@ sub-directories:
The server can be run within either MzScheme or MrEd, but "utils.ss"
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,
but terminating the server is no worse than a network outage. (In
particular, no data should be lost.) To reconfigure the server (e.g.,
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.
The client and server are designed to be robust against network
problems and timeouts. The client-side tool always provides a "cancel"
button for any network transaction. For handins, "cancel" is
problems and timeouts. The client-side tool always provides a
"cancel" button for any network transaction. For handins, "cancel" is
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
the submission (having run it through the checker, if any), but before
renaming "ATTEMPT". Also, the server responds to a commit with "ok"
only after it has written the file. Thus, when the client-side tool
reports that the handin was successful, the report is
reliable. Meanwhile, the tool can also report successful cancels most
of the time. In the (normally brief) time between a commit and an "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
reports that the handin was successful, the report is reliable.
Meanwhile, the tool can also report successful cancels most of the
time. In the (normally brief) time between a commit and an "ok"
response, the tool gives the student a suitable warning that the
cancel is unreliable.
To minimize human error, the number of active assignments should be
limited to one whenever possible. When multiple assignments are
limited to one whenever possible. When multiple assignments are
active, design a checker to help ensure that the student has selected
the correct assignment in the handin dialog.
A student can download his/her own submissions through a web server
that runs concurrently with the handin server. The starting URL is
that runs concurrently with the handin server. The starting URL is
https://SERVER:PORT/servlets/status.ss
@ -512,7 +515,7 @@ to obtain a list of all assignments, or
https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT
to start with a specific assignment (named ASSIGNMENT). The default
to start with a specific assignment (named ASSIGNMENT). The default
PORT is 7980.
@ -522,14 +525,15 @@ Checker Utilities
The _utils.ss_ module provides utilities helpful in implementing
`checker' functions:
> (unpack-submission bytes) - returns two text% objects corresponding
to the submitted definitions and interactions windows.
> (unpack-submission bytes)
Returns two text% objects corresponding to the submitted definitions
and interactions windows.
> (make-evaluator language teachpack-paths program-port) - returns a
function of one required argument for evaluating expressions in the
designated language, and loading teachpacks that are specified in
`teachpack-paths'. The `program-port' is an input port that
produces the content of the definitions window; use
> (make-evaluator language teachpack-paths program-port)
Returns a function of one required argument for evaluating
expressions in the designated language, and loading teachpacks that
are specified in `teachpack-paths'. The `program-port' is an input
port that produces the content of the definitions window; use
`(open-input-string "")' for an empty definitions window.
The `language' can be:
@ -557,114 +561,118 @@ The _utils.ss_ module provides utilities helpful in implementing
that retrieve additional information. Currently, only
'execute-counts is used (see below).
> (make-evaluator/submission language teachpack-paths bytes) - like
`make-evaluator', but the definitions content is supplied as a
> (make-evaluator/submission language teachpack-paths bytes)
Like `make-evaluator', but the definitions content is supplied as a
submission byte string. The byte string is opened for reading, with
line-counting enabled.
> (call-with-evaluator language teachpack-paths program-port proc) -
calls `proc' with an evaluator for the given language, teachpack
paths, and initial definition content as supplied by a port. It also
sets the current error-value print handler to print values in a way
suitable for `lang', it initializes `current-run-status' with
> (call-with-evaluator language teachpack-paths program-port proc)
Calls `proc' with an evaluator for the given language, teachpack
paths, and initial definition content as supplied by a port. It
also sets the current error-value print handler to print values in a
way suitable for `lang', it initializes `current-run-status' with
"executing your code", and it catches all exceptions to re-raise
them in a form suitable as a submission error.
> (call-with-evaluator/submission language teachpack-paths bytes proc) -
like `call-with-evaluator', but the definitions content is supplied
as a submission string. The byte string is opened for reading,
with line-counting enabled.
> (call-with-evaluator/submission language teachpack-paths bytes proc)
Like `call-with-evaluator', but the definitions content is supplied
as a submission string. The byte string is opened for reading, with
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
port.
> (evaluate-submission bytes eval)
Like `load' on a non-test-suite submission byte string.
> (evaluate-submission bytes eval) - like `load' on a non-test-suite
submission byte string.
> coverage-enabled
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.
> coverage-enabled - 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 ...) - 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.
> (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'
phrased suitably for the handin client.
> (check-defined eval name) - checks whether `name' is defined in the
evaluator `eval', and raises an error if not (suitably phrased for
the handin client). If it is defined as non-syntax, its value is
returned. Warning: in the beginner language level, procedure
definitions are bound as syntax.
> (check-defined eval name)
Checks whether `name' is defined in the evaluator `eval', and raises
an error if not (suitably phrased for the handin client). If it is
defined as non-syntax, its value is returned. Warning: in the
beginner language level, procedure definitions are bound as syntax.
> (look-for-tests text name n) - inspects the given text% object to
determine whether it contains at least `n' tests for the function
`name'. The tests must be top-level expressions.
> (look-for-tests text name n)
Inspects the given text% object to determine whether it contains at
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
result checking. This function is often useful for calling a
student-defined constructor.
> (user-construct eval name arg ...)
Like `check-proc', but with no result checking. This function is
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
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.
> (message string [styles])
If given only a string, this string will be shown on the client's
submission dialog; if `styles' is also given, it can be the symbol
'final, which will be used as the text on the handin dialog after a
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
be shown on the client's submission dialog; if `styles' is also
given, it can be the symbol 'final, which will be used as the text
on the handin dialog after a 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.
> (current-run-status string-or-#f)
Registers information about the current actions of the checker, in
case the session is terminated due to excessive memory consumption.
For example, a checker might set the status to indicate which
instructor-supplied test was being executed when the session ran out
of memory. This status is only 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-run-status string-or-#f) - registers information about the
current actions of the checker, in case the session is terminated
due to excessive memory consumption. For example, a checker might
set the status to indicate which instructor-supplied test was being
executed when the session ran out of memory. This status is only
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 are printed, a procedure that
expects a Scheme value and returns a string representation for it.
The default value printer uses pretty-print, with DrScheme-like
settings.
> (current-value-printer proc) - a parameter that controls how values
are printed, a procedure that expects a Scheme value and returns a
string representation for it. The default value printer uses
pretty-print, with DrScheme-like settings.
> (reraise-exn-as-submission-problem thunk)
Calls thunk in a context that catches exceptions and re-raises them
in a form suitable as a submission error.
> (reraise-exn-as-submission-problem thunk) - calls thunk in a context
that catches exceptions and re-raises them in a form suitable as a
submission error.
> (log-line fmt args ...)
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.
> (LOG fmt args ...) - produces a line in the server log file, using
the given format string and arguments.
> (timeout-control msg) - control the timeout for this session. The
timeout is initialized by the value of the 'session-timeout
configuration entry, and the checker can use this procedure to
further control it: if msg is 'reset the timeout is reset to
'session-timeout seconds; if msg is a number the timeout will be set
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.)
> (timeout-control msg)
Control the timeout for this session. The timeout is initialized by
the value of the 'session-timeout configuration entry, and the
checker can use this procedure to further control it: if msg is
'reset the timeout is reset to 'session-timeout seconds; if msg is a
number the timeout will be set 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
@ -780,10 +788,10 @@ Keywords for configuring `check:':
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",
"~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
these:
message. The default is "Error in your code --\n~a". Useful
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
Hit \"Run\" and debug your code."
@ -798,8 +806,10 @@ Keywords for configuring `check:':
(message (string-append
"You have an error in your program -- please hit"
" \"Run\" and debug your code.\n"
"Email the course staff if you think your code is fine.\n"
"(The submission has been saved but marked as erroneous.)")
"Email the course staff if you think your code is"
" fine.\n"
"(The submission has been saved but marked as"
" erroneous.)")
'(ok))
(message "Handin saved as erroneous." 'final))
@ -841,7 +851,7 @@ value from the submission code.
(file-size "hw.scm")
(file-or-directory-modify-seconds "hw.scm")))
(timeout-control 'disable)
(LOG "Sending a receipt: ~a" info)
(log-line "Sending a receipt: ~a" info)
(send-mail-message
"course-staff@university.edu"
"Submission Receipt"

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

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

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

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

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

@ -1,47 +1,46 @@
(module utils mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "posn.ss" "lang")
"run-status.ss"
(prefix pc: (lib "pconvert.ss"))
(lib "pretty.ss")
(lib "list.ss")
(lib "string.ss")
(only "handin-server.ss" LOG timeout-control))
(lib "mred.ss" "mred")
(lib "posn.ss" "lang")
"private/run-status.ss"
(prefix pc: (lib "pconvert.ss"))
(lib "pretty.ss")
(lib "list.ss")
(lib "string.ss")
(only "handin-server.ss" timeout-control))
(provide unpack-submission
unpack-test-suite-submission
is-test-suite-submission?
unpack-test-suite-submission
is-test-suite-submission?
make-evaluator
make-evaluator/submission
evaluate-all
evaluate-submission
make-evaluator
make-evaluator/submission
evaluate-all
evaluate-submission
call-with-evaluator
call-with-evaluator/submission
reraise-exn-as-submission-problem
current-run-status
message
call-with-evaluator
call-with-evaluator/submission
reraise-exn-as-submission-problem
current-run-status
message
current-value-printer
coverage-enabled
coverage-enabled
check-proc
check-defined
look-for-tests
user-construct
test-history-enabled
check-proc
check-defined
look-for-tests
user-construct
test-history-enabled
LOG
timeout-control)
timeout-control)
(define (unpack-submission str)
(let* ([base (make-object editor-stream-in-bytes-base% str)]
[stream (make-object editor-stream-in% base)]
[definitions-text (make-object text%)]
[interactions-text (make-object text%)])
[stream (make-object editor-stream-in% base)]
[definitions-text (make-object text%)]
[interactions-text (make-object text%)])
(read-editor-version stream base #t)
(read-editor-global-header stream)
(send definitions-text read-from-file stream)
@ -51,8 +50,8 @@
(define (unpack-test-suite-submission str)
(let* ([base (make-object editor-stream-in-bytes-base% str)]
[stream (make-object editor-stream-in% base)]
[ts (make-object ts-load%)])
[stream (make-object editor-stream-in% base)]
[ts (make-object ts-load%)])
(read-editor-version stream base #t)
(read-editor-global-header stream)
(send ts read-from-file stream)
@ -61,7 +60,7 @@
(define (is-test-suite-submission? str)
(send (unpack-test-suite-submission str)
got-program?))
got-program?))
;; Test Suite Unpacking ----------------------------------------
;; This code duplicates just enough of the test-suite snips
@ -70,12 +69,12 @@
(define program-header-field-name "drscheme:test-suite:program")
(define csc (new
(class snip-class%
(define/override (read f)
(let ([case (new case%)])
(send case read-from-file f)
case))
(super-new))))
(class snip-class%
(define/override (read f)
(let ([case (new case%)])
(send case read-from-file f)
case))
(super-new))))
(send csc set-classname "case%")
(send csc set-version 1)
(send (get-the-snip-class-list) add csc)
@ -89,10 +88,10 @@
(define test (new text%))
(define/public (read-from-file f)
(send call read-from-file f)
(send expected read-from-file f)
(send test read-from-file f)
(send f get-string))
(send call read-from-file f)
(send expected read-from-file f)
(send test read-from-file f)
(send f get-string))
(super-new)
@ -102,12 +101,12 @@
(send (get-editor) insert (make-object editor-snip% test))))
(define dsc (new
(class snip-class%
(define/override (read f)
(let ([helper (new helper%)])
(send helper read-from-file f)
helper))
(super-new))))
(class snip-class%
(define/override (read f)
(let ([helper (new helper%)])
(send helper read-from-file f)
helper))
(super-new))))
(send dsc set-classname "drscheme:test-suite:helper%")
(send dsc set-version 1)
(send (get-the-snip-class-list) add dsc)
@ -117,7 +116,7 @@
(inherit set-snipclass get-editor)
(define/public (read-from-file f)
(send (get-editor) read-from-file f))
(send (get-editor) read-from-file f))
(super-new)
@ -131,11 +130,11 @@
(define/public (got-program?) got-p?)
(define/override (read-header-from-file stream name)
(if (string=? name program-header-field-name)
(begin
(set! got-p? #t)
(send program read-from-file stream))
(super read-header-from-file stream name)))
(if (string=? name program-header-field-name)
(begin
(set! got-p? #t)
(send program read-from-file stream))
(super read-header-from-file stream name)))
(super-new)))
@ -177,7 +176,7 @@
(define modules-to-attach
(list '(lib "posn.ss" "lang")
'(lib "cache-image-snip.ss" "mrlib")))
'(lib "cache-image-snip.ss" "mrlib")))
(define (make-evaluation-namespace)
(let ([new-ns (make-namespace-with-mred)]
@ -196,19 +195,19 @@
(let ([coverage-enabled (coverage-enabled)]
[execute-counts #f]
[ns (make-evaluation-namespace)]
[orig-ns (current-namespace)])
[orig-ns (current-namespace)])
(parameterize ([current-namespace ns]
[read-case-sensitive #t]
[read-decimal-as-inexact #f]
[current-inspector (make-inspector)])
(parameterize ([current-eventspace (make-eventspace)])
(let ([ch (make-channel)]
[result-ch (make-channel)])
(queue-callback
(lambda ()
;; First read program and evaluate it as a module:
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
(let* ([body
[read-case-sensitive #t]
[read-decimal-as-inexact #f]
[current-inspector (make-inspector)])
(parameterize ([current-eventspace (make-eventspace)])
(let ([ch (make-channel)]
[result-ch (make-channel)])
(queue-callback
(lambda ()
;; First read program and evaluate it as a module:
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
(let* ([body
(parameterize ([read-case-sensitive #t]
[read-decimal-as-inexact #f])
(let loop ([l null])
@ -267,22 +266,22 @@
(filter (lambda (x)
(eq? 'program (syntax-source (car x))))
(safe-eval '(get-execute-counts) ns))))))
(channel-put result-ch 'ok))
;; Now wait for interaction expressions:
(let loop ()
(let ([expr (channel-get ch)])
(unless (eof-object? expr)
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(channel-put result-ch (cons 'val (safe-eval expr))))
(loop))))
(let loop ()
(channel-put result-ch '(exn . no-more-to-evaluate))
(loop))))
(let ([r (channel-get result-ch)])
(if (eq? r 'ok)
;; Initial program executed ok, so return an evaluator:
(lambda (expr . more)
(channel-put result-ch 'ok))
;; Now wait for interaction expressions:
(let loop ()
(let ([expr (channel-get ch)])
(unless (eof-object? expr)
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(channel-put result-ch (cons 'val (safe-eval expr))))
(loop))))
(let loop ()
(channel-put result-ch '(exn . no-more-to-evaluate))
(loop))))
(let ([r (channel-get result-ch)])
(if (eq? r 'ok)
;; Initial program executed ok, so return an evaluator:
(lambda (expr . more)
(if (pair? more)
(case (car more)
[(execute-counts) execute-counts]
@ -294,8 +293,8 @@
(if (eq? (car r) 'exn)
(raise (cdr r))
(cdr r))))))
;; Program didn't execute:
(raise (cdr r)))))))))
;; Program didn't execute:
(raise (cdr r)))))))))
(define (open-input-text-editor/lines str)
(let ([inp (open-input-text-editor str)])
@ -308,11 +307,11 @@
(define (evaluate-all source port eval)
(let loop ()
(let ([expr (parameterize ([read-case-sensitive #t]
[read-decimal-as-inexact #f])
(read-syntax source port))])
(unless (eof-object? expr)
(eval expr)
(loop)))))
[read-decimal-as-inexact #f])
(read-syntax source port))])
(unless (eof-object? expr)
(eval expr)
(loop)))))
(define (evaluate-submission str eval)
(let-values ([(defs interacts) (unpack-submission str)])
@ -320,10 +319,10 @@
(define (reraise-exn-as-submission-problem thunk)
(with-handlers ([void (lambda (exn)
(error
(if (exn? exn)
(exn-message exn)
(format "~s" exn))))])
(error
(if (exn? exn)
(exn-message exn)
(format "~s" exn))))])
(thunk)))
;; ----------------------------------------
@ -331,56 +330,56 @@
(define (check-defined e id)
(with-handlers ([exn:fail:syntax? void]
[exn:fail:contract:variable?
(lambda (x)
(error
(format
"\"~a\" is not defined, but it must be defined for handin"
(exn:fail:contract:variable-id x))))])
[exn:fail:contract:variable?
(lambda (x)
(error
(format
"\"~a\" is not defined, but it must be defined for handin"
(exn:fail:contract:variable-id x))))])
(e #`(#,namespace-variable-value '#,id #t))))
(define (mk-args args)
(let loop ([l args])
(if (null? l)
""
(string-append " " (format "~e" (car l)) (loop (cdr l))))))
""
(string-append " " (format "~e" (car l)) (loop (cdr l))))))
(define test-history-enabled (make-parameter #f))
(define test-history (make-parameter null))
(define (format-history one-test)
(if (test-history-enabled)
(format "(begin~a)"
(apply string-append
(map (lambda (s)
(format " ~a" s))
(reverse (test-history)))))
one-test))
(format "(begin~a)"
(apply string-append
(map (lambda (s)
(format " ~a" s))
(reverse (test-history)))))
one-test))
(define (check-proc e result equal? f . args)
(let ([test (format "(~a~a)" f (mk-args args))])
(when (test-history-enabled)
(test-history (cons test (test-history))))
(test-history (cons test (test-history))))
(current-run-status (format "running instructor-supplied test ~a"
(format-history test)))
(format-history test)))
(let-values ([(ok? val)
(with-handlers ([void
(lambda (x)
(error
(format "instructor-supplied test ~a failed with an error: ~e"
(format-history test)
(exn-message x))))])
(let ([val (e `(,f ,@(map value-converter args)))])
(values (or (eq? 'anything result)
(equal? val result))
val)))])
(unless ok?
(error
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
(format-history test)
result
val)))
val)))
(with-handlers ([void
(lambda (x)
(error
(format "instructor-supplied test ~a failed with an error: ~e"
(format-history test)
(exn-message x))))])
(let ([val (e `(,f ,@(map value-converter args)))])
(values (or (eq? 'anything result)
(equal? val result))
val)))])
(unless ok?
(error
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
(format-history test)
result
val)))
val)))
(define (user-construct e func . args)
(apply check-proc e func 'anything eq? args))
@ -388,50 +387,50 @@
(define (look-for-tests t name count)
(let ([p (open-input-text-editor/lines t)])
(let loop ([found 0])
(let ([e (read p)])
(if (eof-object? e)
(when (found . < . count)
(error (format "found ~a test~a for ~a, need at least ~a test~a"
found
(if (= found 1) "" "s")
name
count
(if (= count 1) "" "s"))))
(loop (+ found
(if (and (pair? e)
(eq? (car e) name))
1
0))))))))
(let ([e (read p)])
(if (eof-object? e)
(when (found . < . count)
(error (format "found ~a test~a for ~a, need at least ~a test~a"
found
(if (= found 1) "" "s")
name
count
(if (= count 1) "" "s"))))
(loop (+ found
(if (and (pair? e)
(eq? (car e) name))
1
0))))))))
(define list-abbreviation-enabled (make-parameter #f))
(define (value-converter v)
(parameterize ([pc:booleans-as-true/false #t]
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
[pc:constructor-style-printing #t])
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
[pc:constructor-style-printing #t])
(pc:print-convert v)))
(define (default-value-printer v)
(parameterize ([pretty-print-show-inexactness #t]
[pretty-print-.-symbol-without-bars #t]
[pretty-print-exact-as-decimal #t]
[pretty-print-columns +inf.0]
[read-case-sensitive #t])
[pretty-print-.-symbol-without-bars #t]
[pretty-print-exact-as-decimal #t]
[pretty-print-columns +inf.0]
[read-case-sensitive #t])
(let ([p (open-output-string)])
(pretty-print (value-converter v) p)
(regexp-replace #rx"\n$" (get-output-string p) ""))))
(pretty-print (value-converter v) p)
(regexp-replace #rx"\n$" (get-output-string p) ""))))
(define current-value-printer (make-parameter default-value-printer))
(define (call-with-evaluator lang teachpacks program-port go)
(parameterize ([error-value->string-handler (lambda (v s)
((current-value-printer) v))]
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
(eq? lang 'beginner-abbr)))])
((current-value-printer) v))]
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
(eq? lang 'beginner-abbr)))])
(reraise-exn-as-submission-problem
(lambda ()
(let ([e (make-evaluator lang teachpacks program-port)])
(current-run-status "executing your code")
(go e))))))
(let ([e (make-evaluator lang teachpacks program-port)])
(current-run-status "executing your code")
(go e))))))
(define (call-with-evaluator/submission lang teachpacks str go)
(let-values ([(defs interacts) (unpack-submission str)])