* New logging facility: simply use current-error-port as a logging output
- 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
parent
b8924dfbea
commit
c19e157b48
|
|
@ -6,24 +6,24 @@ instructor for accepting homework assignments and reporting on
|
||||||
submitted assignments.
|
submitted assignments.
|
||||||
|
|
||||||
The "handin-client" directory contains a client to be customized then
|
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
|
embed a particular hostname and port where the server is running, as
|
||||||
well as a server certificate.
|
well as a server certificate.
|
||||||
|
|
||||||
With a customized client, students simply install a ".plt" file --- so
|
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
|
student can install any number of clients at once (assuming that the
|
||||||
clients are properly customized, as described below).
|
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.
|
||||||
|
|
@ -93,16 +93,16 @@ Client Customization
|
||||||
To customize the client:
|
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:
|
||||||
|
|
||||||
* For `name', choose a name for the handin tool as it will
|
* For `name', choose a name for the handin tool as it will
|
||||||
appear in DrScheme's interface (e.g., the "XXX" for the
|
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
|
name specific to the course, in case a student installs
|
||||||
multiple handin tools. Do not use "Handin" as the last part
|
multiple handin tools. Do not use "Handin" as the last part
|
||||||
of the name, since "Handin" is always added for button and
|
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.
|
menu that opens a (course-specific) web page.
|
||||||
|
|
||||||
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
|
||||||
"handin-client" collection is ok for testing, but the point of
|
"handin-client" collection is ok for testing, but the point of
|
||||||
this certificate is to make handins secure, so you should
|
this certificate is to make handins secure, so you should
|
||||||
generate a new (self-certifying) certificate and keep its key
|
generate a new (self-certifying) certificate and keep its key
|
||||||
private. (See server setup, below.)
|
private. (See server setup, below.)
|
||||||
|
|
||||||
5. Run
|
5. Run
|
||||||
mzc --collection-plt <name>.plt <name>
|
mzc --collection-plt <name>.plt <name>
|
||||||
|
|
@ -139,9 +139,9 @@ To customize the client:
|
||||||
(i.e., whatever you changed "handin-client" to).
|
(i.e., whatever you changed "handin-client" to).
|
||||||
|
|
||||||
6. Distribute <name>.plt to students for installation into their
|
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
|
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
|
install it once on a shared installation, use setup-plt with the
|
||||||
--all-users flag.
|
--all-users flag.
|
||||||
|
|
||||||
|
|
@ -150,18 +150,19 @@ Server Setup
|
||||||
============================================
|
============================================
|
||||||
|
|
||||||
The server must be run from a directory that is specially prepared to
|
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:
|
sub-directories:
|
||||||
|
|
||||||
* "server-cert.pem" --- the server's certificate. To create a
|
* "server-cert.pem" --- the server's certificate. To create a
|
||||||
certificate and key with openssl:
|
certificate and key with openssl:
|
||||||
|
|
||||||
openssl req -new -nodes -x509 -days 365 -out server-cert.pem
|
openssl req -new -nodes -x509 -days 365 -out server-cert.pem
|
||||||
-keyout private-key.pem
|
-keyout private-key.pem
|
||||||
|
|
||||||
* "private-key.pem" --- the private key to go with "server-cert.pem".
|
* "private-key.pem" --- the private key to go with
|
||||||
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
|
||||||
|
|
@ -280,7 +281,7 @@ sub-directories:
|
||||||
the list of user accounts, along with the associated password
|
the list of user accounts, along with the associated password
|
||||||
(actually the MD5 hash of the password), and extra string fields
|
(actually the MD5 hash of the password), and extra string fields
|
||||||
as specified by the 'extra-fields configuration entry (in the same
|
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> ...))
|
((<username-sym> (<pw-md5-str> <extra-field> ...))
|
||||||
...)
|
...)
|
||||||
|
|
@ -291,13 +292,13 @@ sub-directories:
|
||||||
...)
|
...)
|
||||||
|
|
||||||
Username that begin with "solution" are special. They are used by
|
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
|
'username-case-sensitive? configuration items, usernames are not
|
||||||
allowed to contain characters that are illegal in Windows
|
allowed to contain characters that are illegal in Windows
|
||||||
pathnames, they cannot end or begin in spaces or periods.
|
pathnames, they cannot end or begin in spaces or periods.
|
||||||
|
|
||||||
If the 'allow-new-users configuration allows new users, the
|
If the 'allow-new-users configuration allows new users, the
|
||||||
"users.ss" file can be updated by the server with new users. It
|
"users.ss" file can be updated by the server with new users. It
|
||||||
can always be updated by the server to change passwords.
|
can always be updated by the server to change passwords.
|
||||||
|
|
||||||
If you have access to a standard Unix password file (from
|
If you have access to a standard Unix password file (from
|
||||||
|
|
@ -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,34 +478,36 @@ 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
|
||||||
particular, no data should be lost.) To reconfigure the server (e.g.,
|
particular, no data should be lost.) To reconfigure the server (e.g.,
|
||||||
to change the set of active assignments), stop it and restart it.
|
to change 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.
|
||||||
|
|
||||||
To minimize human error, the number of active assignments should be
|
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
|
active, design a checker to help ensure that the student has selected
|
||||||
the correct assignment in the handin dialog.
|
the correct assignment in the handin dialog.
|
||||||
|
|
||||||
A student can download his/her own submissions through a web server
|
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
|
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
|
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.
|
PORT is 7980.
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -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"
|
||||||
|
|
|
||||||
|
|
@ -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,8 +105,8 @@
|
||||||
[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
|
||||||
;; SUCCESS, or things that are newer in the main submission
|
;; SUCCESS, or things that are newer in the main submission
|
||||||
|
|
@ -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,8 +429,8 @@
|
||||||
(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)))
|
||||||
|
|
||||||
(define (get-user-info data)
|
(define (get-user-info 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,9 +596,9 @@
|
||||||
[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
|
||||||
w (format "handin terminated due to ~a (program doesn't terminate?)~a"
|
w (format "handin terminated due to ~a (program doesn't terminate?)~a"
|
||||||
(if timed-out? "time limit" "excessive memory use")
|
(if timed-out? "time limit" "excessive memory use")
|
||||||
|
|
@ -627,12 +614,12 @@
|
||||||
(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)"
|
||||||
(list (current-memory-use orig-custodian)
|
(list (current-memory-use orig-custodian)
|
||||||
(current-memory-use))))
|
(current-memory-use))))
|
||||||
(loop #f)]))))))])
|
(loop #f)]))))))])
|
||||||
;; Run proc in a thread under session-cust:
|
;; Run proc in a thread under session-cust:
|
||||||
(let ([session-thread
|
(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 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)
|
||||||
|
|
@ -681,10 +666,10 @@
|
||||||
(with-handlers ([exn:fail?
|
(with-handlers ([exn:fail?
|
||||||
(lambda (exn)
|
(lambda (exn)
|
||||||
(let ([msg (if (exn? exn)
|
(let ([msg (if (exn? exn)
|
||||||
(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
51
collects/handin-server/private/logger.ss
Normal 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)))))
|
||||||
|
|
@ -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,25 +232,25 @@
|
||||||
(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))))]
|
||||||
[html? (regexp-match #rx"[.]html?$" (string-foldcase tag))]
|
[html? (regexp-match #rx"[.]html?$" (string-foldcase tag))]
|
||||||
[wxme? (regexp-match #rx#"^WXME" data)])
|
[wxme? (regexp-match #rx#"^WXME" data)])
|
||||||
(make-response/full 200 "Okay" (current-seconds)
|
(make-response/full 200 "Okay" (current-seconds)
|
||||||
(cond [html? #"text/html"]
|
(cond [html? #"text/html"]
|
||||||
[wxme? #"application/data"]
|
[wxme? #"application/data"]
|
||||||
[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)
|
||||||
(if for-handin
|
(if for-handin
|
||||||
|
|
|
||||||
|
|
@ -1,47 +1,46 @@
|
||||||
(module utils mzscheme
|
(module utils mzscheme
|
||||||
(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
|
||||||
|
|
||||||
unpack-test-suite-submission
|
unpack-test-suite-submission
|
||||||
is-test-suite-submission?
|
is-test-suite-submission?
|
||||||
|
|
||||||
make-evaluator
|
make-evaluator
|
||||||
make-evaluator/submission
|
make-evaluator/submission
|
||||||
evaluate-all
|
evaluate-all
|
||||||
evaluate-submission
|
evaluate-submission
|
||||||
|
|
||||||
call-with-evaluator
|
call-with-evaluator
|
||||||
call-with-evaluator/submission
|
call-with-evaluator/submission
|
||||||
reraise-exn-as-submission-problem
|
reraise-exn-as-submission-problem
|
||||||
current-run-status
|
current-run-status
|
||||||
message
|
message
|
||||||
current-value-printer
|
current-value-printer
|
||||||
|
|
||||||
coverage-enabled
|
coverage-enabled
|
||||||
|
|
||||||
check-proc
|
check-proc
|
||||||
check-defined
|
check-defined
|
||||||
look-for-tests
|
look-for-tests
|
||||||
user-construct
|
user-construct
|
||||||
test-history-enabled
|
test-history-enabled
|
||||||
|
|
||||||
LOG
|
timeout-control)
|
||||||
timeout-control)
|
|
||||||
|
|
||||||
(define (unpack-submission str)
|
(define (unpack-submission str)
|
||||||
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
||||||
[stream (make-object editor-stream-in% base)]
|
[stream (make-object editor-stream-in% base)]
|
||||||
[definitions-text (make-object text%)]
|
[definitions-text (make-object text%)]
|
||||||
[interactions-text (make-object text%)])
|
[interactions-text (make-object text%)])
|
||||||
(read-editor-version stream base #t)
|
(read-editor-version stream base #t)
|
||||||
(read-editor-global-header stream)
|
(read-editor-global-header stream)
|
||||||
(send definitions-text read-from-file stream)
|
(send definitions-text read-from-file stream)
|
||||||
|
|
@ -51,8 +50,8 @@
|
||||||
|
|
||||||
(define (unpack-test-suite-submission str)
|
(define (unpack-test-suite-submission str)
|
||||||
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
||||||
[stream (make-object editor-stream-in% base)]
|
[stream (make-object editor-stream-in% base)]
|
||||||
[ts (make-object ts-load%)])
|
[ts (make-object ts-load%)])
|
||||||
(read-editor-version stream base #t)
|
(read-editor-version stream base #t)
|
||||||
(read-editor-global-header stream)
|
(read-editor-global-header stream)
|
||||||
(send ts read-from-file stream)
|
(send ts read-from-file stream)
|
||||||
|
|
@ -61,7 +60,7 @@
|
||||||
|
|
||||||
(define (is-test-suite-submission? str)
|
(define (is-test-suite-submission? str)
|
||||||
(send (unpack-test-suite-submission str)
|
(send (unpack-test-suite-submission str)
|
||||||
got-program?))
|
got-program?))
|
||||||
|
|
||||||
;; Test Suite Unpacking ----------------------------------------
|
;; Test Suite Unpacking ----------------------------------------
|
||||||
;; This code duplicates just enough of the test-suite snips
|
;; This code duplicates just enough of the test-suite snips
|
||||||
|
|
@ -70,12 +69,12 @@
|
||||||
(define program-header-field-name "drscheme:test-suite:program")
|
(define program-header-field-name "drscheme:test-suite:program")
|
||||||
|
|
||||||
(define csc (new
|
(define csc (new
|
||||||
(class snip-class%
|
(class snip-class%
|
||||||
(define/override (read f)
|
(define/override (read f)
|
||||||
(let ([case (new case%)])
|
(let ([case (new case%)])
|
||||||
(send case read-from-file f)
|
(send case read-from-file f)
|
||||||
case))
|
case))
|
||||||
(super-new))))
|
(super-new))))
|
||||||
(send csc set-classname "case%")
|
(send csc set-classname "case%")
|
||||||
(send csc set-version 1)
|
(send csc set-version 1)
|
||||||
(send (get-the-snip-class-list) add csc)
|
(send (get-the-snip-class-list) add csc)
|
||||||
|
|
@ -89,10 +88,10 @@
|
||||||
(define test (new text%))
|
(define test (new text%))
|
||||||
|
|
||||||
(define/public (read-from-file f)
|
(define/public (read-from-file f)
|
||||||
(send call read-from-file f)
|
(send call read-from-file f)
|
||||||
(send expected read-from-file f)
|
(send expected read-from-file f)
|
||||||
(send test read-from-file f)
|
(send test read-from-file f)
|
||||||
(send f get-string))
|
(send f get-string))
|
||||||
|
|
||||||
(super-new)
|
(super-new)
|
||||||
|
|
||||||
|
|
@ -102,12 +101,12 @@
|
||||||
(send (get-editor) insert (make-object editor-snip% test))))
|
(send (get-editor) insert (make-object editor-snip% test))))
|
||||||
|
|
||||||
(define dsc (new
|
(define dsc (new
|
||||||
(class snip-class%
|
(class snip-class%
|
||||||
(define/override (read f)
|
(define/override (read f)
|
||||||
(let ([helper (new helper%)])
|
(let ([helper (new helper%)])
|
||||||
(send helper read-from-file f)
|
(send helper read-from-file f)
|
||||||
helper))
|
helper))
|
||||||
(super-new))))
|
(super-new))))
|
||||||
(send dsc set-classname "drscheme:test-suite:helper%")
|
(send dsc set-classname "drscheme:test-suite:helper%")
|
||||||
(send dsc set-version 1)
|
(send dsc set-version 1)
|
||||||
(send (get-the-snip-class-list) add dsc)
|
(send (get-the-snip-class-list) add dsc)
|
||||||
|
|
@ -117,7 +116,7 @@
|
||||||
(inherit set-snipclass get-editor)
|
(inherit set-snipclass get-editor)
|
||||||
|
|
||||||
(define/public (read-from-file f)
|
(define/public (read-from-file f)
|
||||||
(send (get-editor) read-from-file f))
|
(send (get-editor) read-from-file f))
|
||||||
|
|
||||||
(super-new)
|
(super-new)
|
||||||
|
|
||||||
|
|
@ -131,11 +130,11 @@
|
||||||
(define/public (got-program?) got-p?)
|
(define/public (got-program?) got-p?)
|
||||||
|
|
||||||
(define/override (read-header-from-file stream name)
|
(define/override (read-header-from-file stream name)
|
||||||
(if (string=? name program-header-field-name)
|
(if (string=? name program-header-field-name)
|
||||||
(begin
|
(begin
|
||||||
(set! got-p? #t)
|
(set! got-p? #t)
|
||||||
(send program read-from-file stream))
|
(send program read-from-file stream))
|
||||||
(super read-header-from-file stream name)))
|
(super read-header-from-file stream name)))
|
||||||
|
|
||||||
(super-new)))
|
(super-new)))
|
||||||
|
|
||||||
|
|
@ -177,7 +176,7 @@
|
||||||
|
|
||||||
(define modules-to-attach
|
(define modules-to-attach
|
||||||
(list '(lib "posn.ss" "lang")
|
(list '(lib "posn.ss" "lang")
|
||||||
'(lib "cache-image-snip.ss" "mrlib")))
|
'(lib "cache-image-snip.ss" "mrlib")))
|
||||||
|
|
||||||
(define (make-evaluation-namespace)
|
(define (make-evaluation-namespace)
|
||||||
(let ([new-ns (make-namespace-with-mred)]
|
(let ([new-ns (make-namespace-with-mred)]
|
||||||
|
|
@ -196,19 +195,19 @@
|
||||||
(let ([coverage-enabled (coverage-enabled)]
|
(let ([coverage-enabled (coverage-enabled)]
|
||||||
[execute-counts #f]
|
[execute-counts #f]
|
||||||
[ns (make-evaluation-namespace)]
|
[ns (make-evaluation-namespace)]
|
||||||
[orig-ns (current-namespace)])
|
[orig-ns (current-namespace)])
|
||||||
(parameterize ([current-namespace ns]
|
(parameterize ([current-namespace ns]
|
||||||
[read-case-sensitive #t]
|
[read-case-sensitive #t]
|
||||||
[read-decimal-as-inexact #f]
|
[read-decimal-as-inexact #f]
|
||||||
[current-inspector (make-inspector)])
|
[current-inspector (make-inspector)])
|
||||||
(parameterize ([current-eventspace (make-eventspace)])
|
(parameterize ([current-eventspace (make-eventspace)])
|
||||||
(let ([ch (make-channel)]
|
(let ([ch (make-channel)]
|
||||||
[result-ch (make-channel)])
|
[result-ch (make-channel)])
|
||||||
(queue-callback
|
(queue-callback
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;; First read program and evaluate it as a module:
|
;; First read program and evaluate it as a module:
|
||||||
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
|
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
|
||||||
(let* ([body
|
(let* ([body
|
||||||
(parameterize ([read-case-sensitive #t]
|
(parameterize ([read-case-sensitive #t]
|
||||||
[read-decimal-as-inexact #f])
|
[read-decimal-as-inexact #f])
|
||||||
(let loop ([l null])
|
(let loop ([l null])
|
||||||
|
|
@ -267,22 +266,22 @@
|
||||||
(filter (lambda (x)
|
(filter (lambda (x)
|
||||||
(eq? 'program (syntax-source (car x))))
|
(eq? 'program (syntax-source (car x))))
|
||||||
(safe-eval '(get-execute-counts) ns))))))
|
(safe-eval '(get-execute-counts) ns))))))
|
||||||
(channel-put result-ch 'ok))
|
(channel-put result-ch 'ok))
|
||||||
;; Now wait for interaction expressions:
|
;; Now wait for interaction expressions:
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(let ([expr (channel-get ch)])
|
(let ([expr (channel-get ch)])
|
||||||
(unless (eof-object? expr)
|
(unless (eof-object? expr)
|
||||||
(with-handlers ([void (lambda (exn)
|
(with-handlers ([void (lambda (exn)
|
||||||
(channel-put result-ch (cons 'exn exn)))])
|
(channel-put result-ch (cons 'exn exn)))])
|
||||||
(channel-put result-ch (cons 'val (safe-eval expr))))
|
(channel-put result-ch (cons 'val (safe-eval expr))))
|
||||||
(loop))))
|
(loop))))
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(channel-put result-ch '(exn . no-more-to-evaluate))
|
(channel-put result-ch '(exn . no-more-to-evaluate))
|
||||||
(loop))))
|
(loop))))
|
||||||
(let ([r (channel-get result-ch)])
|
(let ([r (channel-get result-ch)])
|
||||||
(if (eq? r 'ok)
|
(if (eq? r 'ok)
|
||||||
;; Initial program executed ok, so return an evaluator:
|
;; Initial program executed ok, so return an evaluator:
|
||||||
(lambda (expr . more)
|
(lambda (expr . more)
|
||||||
(if (pair? more)
|
(if (pair? more)
|
||||||
(case (car more)
|
(case (car more)
|
||||||
[(execute-counts) execute-counts]
|
[(execute-counts) execute-counts]
|
||||||
|
|
@ -294,8 +293,8 @@
|
||||||
(if (eq? (car r) 'exn)
|
(if (eq? (car r) 'exn)
|
||||||
(raise (cdr r))
|
(raise (cdr r))
|
||||||
(cdr r))))))
|
(cdr r))))))
|
||||||
;; Program didn't execute:
|
;; Program didn't execute:
|
||||||
(raise (cdr r)))))))))
|
(raise (cdr r)))))))))
|
||||||
|
|
||||||
(define (open-input-text-editor/lines str)
|
(define (open-input-text-editor/lines str)
|
||||||
(let ([inp (open-input-text-editor str)])
|
(let ([inp (open-input-text-editor str)])
|
||||||
|
|
@ -308,11 +307,11 @@
|
||||||
(define (evaluate-all source port eval)
|
(define (evaluate-all source port eval)
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(let ([expr (parameterize ([read-case-sensitive #t]
|
(let ([expr (parameterize ([read-case-sensitive #t]
|
||||||
[read-decimal-as-inexact #f])
|
[read-decimal-as-inexact #f])
|
||||||
(read-syntax source port))])
|
(read-syntax source port))])
|
||||||
(unless (eof-object? expr)
|
(unless (eof-object? expr)
|
||||||
(eval expr)
|
(eval expr)
|
||||||
(loop)))))
|
(loop)))))
|
||||||
|
|
||||||
(define (evaluate-submission str eval)
|
(define (evaluate-submission str eval)
|
||||||
(let-values ([(defs interacts) (unpack-submission str)])
|
(let-values ([(defs interacts) (unpack-submission str)])
|
||||||
|
|
@ -320,10 +319,10 @@
|
||||||
|
|
||||||
(define (reraise-exn-as-submission-problem thunk)
|
(define (reraise-exn-as-submission-problem thunk)
|
||||||
(with-handlers ([void (lambda (exn)
|
(with-handlers ([void (lambda (exn)
|
||||||
(error
|
(error
|
||||||
(if (exn? exn)
|
(if (exn? exn)
|
||||||
(exn-message exn)
|
(exn-message exn)
|
||||||
(format "~s" exn))))])
|
(format "~s" exn))))])
|
||||||
(thunk)))
|
(thunk)))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
@ -331,56 +330,56 @@
|
||||||
|
|
||||||
(define (check-defined e id)
|
(define (check-defined e id)
|
||||||
(with-handlers ([exn:fail:syntax? void]
|
(with-handlers ([exn:fail:syntax? void]
|
||||||
[exn:fail:contract:variable?
|
[exn:fail:contract:variable?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(error
|
(error
|
||||||
(format
|
(format
|
||||||
"\"~a\" is not defined, but it must be defined for handin"
|
"\"~a\" is not defined, but it must be defined for handin"
|
||||||
(exn:fail:contract:variable-id x))))])
|
(exn:fail:contract:variable-id x))))])
|
||||||
(e #`(#,namespace-variable-value '#,id #t))))
|
(e #`(#,namespace-variable-value '#,id #t))))
|
||||||
|
|
||||||
(define (mk-args args)
|
(define (mk-args args)
|
||||||
(let loop ([l args])
|
(let loop ([l args])
|
||||||
(if (null? l)
|
(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-enabled (make-parameter #f))
|
||||||
(define test-history (make-parameter null))
|
(define test-history (make-parameter null))
|
||||||
|
|
||||||
(define (format-history one-test)
|
(define (format-history one-test)
|
||||||
(if (test-history-enabled)
|
(if (test-history-enabled)
|
||||||
(format "(begin~a)"
|
(format "(begin~a)"
|
||||||
(apply string-append
|
(apply string-append
|
||||||
(map (lambda (s)
|
(map (lambda (s)
|
||||||
(format " ~a" s))
|
(format " ~a" s))
|
||||||
(reverse (test-history)))))
|
(reverse (test-history)))))
|
||||||
one-test))
|
one-test))
|
||||||
|
|
||||||
(define (check-proc e result equal? f . args)
|
(define (check-proc e result equal? f . args)
|
||||||
(let ([test (format "(~a~a)" f (mk-args args))])
|
(let ([test (format "(~a~a)" f (mk-args args))])
|
||||||
(when (test-history-enabled)
|
(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"
|
(current-run-status (format "running instructor-supplied test ~a"
|
||||||
(format-history test)))
|
(format-history test)))
|
||||||
(let-values ([(ok? val)
|
(let-values ([(ok? val)
|
||||||
(with-handlers ([void
|
(with-handlers ([void
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(error
|
(error
|
||||||
(format "instructor-supplied test ~a failed with an error: ~e"
|
(format "instructor-supplied test ~a failed with an error: ~e"
|
||||||
(format-history test)
|
(format-history test)
|
||||||
(exn-message x))))])
|
(exn-message x))))])
|
||||||
(let ([val (e `(,f ,@(map value-converter args)))])
|
(let ([val (e `(,f ,@(map value-converter args)))])
|
||||||
(values (or (eq? 'anything result)
|
(values (or (eq? 'anything result)
|
||||||
(equal? val result))
|
(equal? val result))
|
||||||
val)))])
|
val)))])
|
||||||
(unless ok?
|
(unless ok?
|
||||||
(error
|
(error
|
||||||
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
|
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
|
||||||
(format-history test)
|
(format-history test)
|
||||||
result
|
result
|
||||||
val)))
|
val)))
|
||||||
val)))
|
val)))
|
||||||
|
|
||||||
(define (user-construct e func . args)
|
(define (user-construct e func . args)
|
||||||
(apply check-proc e func 'anything eq? args))
|
(apply check-proc e func 'anything eq? args))
|
||||||
|
|
@ -388,50 +387,50 @@
|
||||||
(define (look-for-tests t name count)
|
(define (look-for-tests t name count)
|
||||||
(let ([p (open-input-text-editor/lines t)])
|
(let ([p (open-input-text-editor/lines t)])
|
||||||
(let loop ([found 0])
|
(let loop ([found 0])
|
||||||
(let ([e (read p)])
|
(let ([e (read p)])
|
||||||
(if (eof-object? e)
|
(if (eof-object? e)
|
||||||
(when (found . < . count)
|
(when (found . < . count)
|
||||||
(error (format "found ~a test~a for ~a, need at least ~a test~a"
|
(error (format "found ~a test~a for ~a, need at least ~a test~a"
|
||||||
found
|
found
|
||||||
(if (= found 1) "" "s")
|
(if (= found 1) "" "s")
|
||||||
name
|
name
|
||||||
count
|
count
|
||||||
(if (= count 1) "" "s"))))
|
(if (= count 1) "" "s"))))
|
||||||
(loop (+ found
|
(loop (+ found
|
||||||
(if (and (pair? e)
|
(if (and (pair? e)
|
||||||
(eq? (car e) name))
|
(eq? (car e) name))
|
||||||
1
|
1
|
||||||
0))))))))
|
0))))))))
|
||||||
|
|
||||||
(define list-abbreviation-enabled (make-parameter #f))
|
(define list-abbreviation-enabled (make-parameter #f))
|
||||||
|
|
||||||
(define (value-converter v)
|
(define (value-converter v)
|
||||||
(parameterize ([pc:booleans-as-true/false #t]
|
(parameterize ([pc:booleans-as-true/false #t]
|
||||||
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
|
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
|
||||||
[pc:constructor-style-printing #t])
|
[pc:constructor-style-printing #t])
|
||||||
(pc:print-convert v)))
|
(pc:print-convert v)))
|
||||||
|
|
||||||
(define (default-value-printer v)
|
(define (default-value-printer v)
|
||||||
(parameterize ([pretty-print-show-inexactness #t]
|
(parameterize ([pretty-print-show-inexactness #t]
|
||||||
[pretty-print-.-symbol-without-bars #t]
|
[pretty-print-.-symbol-without-bars #t]
|
||||||
[pretty-print-exact-as-decimal #t]
|
[pretty-print-exact-as-decimal #t]
|
||||||
[pretty-print-columns +inf.0]
|
[pretty-print-columns +inf.0]
|
||||||
[read-case-sensitive #t])
|
[read-case-sensitive #t])
|
||||||
(let ([p (open-output-string)])
|
(let ([p (open-output-string)])
|
||||||
(pretty-print (value-converter v) p)
|
(pretty-print (value-converter v) p)
|
||||||
(regexp-replace #rx"\n$" (get-output-string p) ""))))
|
(regexp-replace #rx"\n$" (get-output-string p) ""))))
|
||||||
(define current-value-printer (make-parameter default-value-printer))
|
(define current-value-printer (make-parameter default-value-printer))
|
||||||
|
|
||||||
(define (call-with-evaluator lang teachpacks program-port go)
|
(define (call-with-evaluator lang teachpacks program-port go)
|
||||||
(parameterize ([error-value->string-handler (lambda (v s)
|
(parameterize ([error-value->string-handler (lambda (v s)
|
||||||
((current-value-printer) v))]
|
((current-value-printer) v))]
|
||||||
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
|
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
|
||||||
(eq? lang 'beginner-abbr)))])
|
(eq? lang 'beginner-abbr)))])
|
||||||
(reraise-exn-as-submission-problem
|
(reraise-exn-as-submission-problem
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ([e (make-evaluator lang teachpacks program-port)])
|
(let ([e (make-evaluator lang teachpacks program-port)])
|
||||||
(current-run-status "executing your code")
|
(current-run-status "executing your code")
|
||||||
(go e))))))
|
(go e))))))
|
||||||
|
|
||||||
(define (call-with-evaluator/submission lang teachpacks str go)
|
(define (call-with-evaluator/submission lang teachpacks str go)
|
||||||
(let-values ([(defs interacts) (unpack-submission str)])
|
(let-values ([(defs interacts) (unpack-submission str)])
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user