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

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

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

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

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

@ -18,12 +18,12 @@ clients are properly customized, as described below).
The result, on the student's side, is a "Handin" button in DrScheme's
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.
@ -94,8 +94,8 @@ 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.
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:
@ -122,9 +122,9 @@ To customize the client:
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.
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
@ -159,9 +159,10 @@ sub-directories:
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
@ -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,7 +478,9 @@ 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
@ -485,16 +488,16 @@ particular, no data should be lost.) To reconfigure the server (e.g.,
to change the set of active assignments), stop it and restart it.
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"
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.
@ -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"

81
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,7 +105,7 @@
[dir (and (pair? dir) (car dir))])
(when dir
(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)))
;; We have a submission directory -- copy all newer things (extra
;; things that exist in the main submission directory but not in
@ -148,14 +135,14 @@
;; exclusive access to the directory contents.
(with-handlers ([void
(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)))])
(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,7 +429,7 @@
(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"
(log-line "change info for ~a ~s -> ~s"
(car usernames) (car user-datas) new-data)
(put-user-data (car usernames) new-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,7 +596,7 @@
[status (if status
(format " while ~a" status)
"")])
(LOG "session killed ~a~a"
(log-line "session killed ~a~a"
(if timed-out? "(timeout) " "(memory)")
status)
(write+flush
@ -627,7 +614,7 @@
(loop #t)]
[else
(collect-garbage)
(LOG "running ~a ~a"
(log-line "running ~a ~a"
(current-memory-use session-cust)
(if no-limit-warning?
"(total)"
@ -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))
(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)
@ -684,7 +669,7 @@
(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

17
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,7 +232,8 @@
(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))))]
@ -240,13 +244,12 @@
[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)])
(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)

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

@ -2,12 +2,12 @@
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "posn.ss" "lang")
"run-status.ss"
"private/run-status.ss"
(prefix pc: (lib "pconvert.ss"))
(lib "pretty.ss")
(lib "list.ss")
(lib "string.ss")
(only "handin-server.ss" LOG timeout-control))
(only "handin-server.ss" timeout-control))
(provide unpack-submission
@ -34,7 +34,6 @@
user-construct
test-history-enabled
LOG
timeout-control)
(define (unpack-submission str)