From c19e157b48fa155e378f207a69c8612ad7ef6be7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 13 Nov 2006 01:24:34 +0000 Subject: [PATCH] * 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 --- collects/handin-server/doc.txt | 296 ++++++++-------- collects/handin-server/handin-server.ss | 107 +++--- collects/handin-server/private/logger.ss | 51 +++ .../handin-server/{ => private}/run-status.ss | 0 .../status-web-root/servlets/status.ss | 29 +- collects/handin-server/utils.ss | 317 +++++++++--------- 6 files changed, 424 insertions(+), 376 deletions(-) create mode 100644 collects/handin-server/private/logger.ss rename collects/handin-server/{ => private}/run-status.ss (100%) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 6d2080fa9b..20105abbfd 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -6,24 +6,24 @@ instructor for accepting homework assignments and reporting on submitted assignments. The "handin-client" directory contains a client to be customized then -re-distributed to students in the course. The customized client will +re-distributed to students in the course. The customized client will embed a particular hostname and port where the server is running, as well as a server certificate. With a customized client, students simply install a ".plt" file --- so -there's no futzing with configuration dialogs and certificates. A +there's no futzing with configuration dialogs and certificates. A student can install any number of clients at once (assuming that the clients are properly customized, as described below). The result, on the student's side, is a "Handin" button in DrScheme's -toolbar. Clicking the "Handin" button allows the student to type a +toolbar. Clicking the "Handin" button allows the student to type a password and upload the current content of the definitions and -interactions window to the course instructor's server. The "File" menu -is also extended with a "Manage..." menu item for managing a handin -account (i.e., changing the password and other information, or +interactions window to the course instructor's server. The "File" +menu is also extended with a "Manage..." menu item for managing a +handin account (i.e., changing the password and other information, or creating a new account if the instructor configures the server to -allow new accounts). Students can submit joint work by submitting with -a concatenation of usernames separated by a "+". +allow new accounts). Students can submit joint work by submitting +with a concatenation of usernames separated by a "+". On the instructor's side, the handin server can be configured to check the student's submission before accepting it. @@ -93,16 +93,16 @@ Client Customization To customize the client: 1. Rename (or make a copy of) the "handin-client" collection - directory. The new name should describe your class uniquely. - For example, "uu-cpsc2010" is a good name for CPSC 2010 - at the University of Utah. + directory. The new name should describe your class uniquely. + For example, "uu-cpsc2010" is a good name for CPSC 2010 at the + University of Utah. 2. Edit the first three definitions of "info.ss" in your renamed client collection: * For `name', choose a name for the handin tool as it will appear in DrScheme's interface (e.g., the "XXX" for the - "Manage XXX Handin Account..." menu item). Again, make the + "Manage XXX Handin Account..." menu item). Again, make the name specific to the course, in case a student installs multiple handin tools. Do not use "Handin" as the last part of the name, since "Handin" is always added for button and @@ -121,17 +121,17 @@ To customize the client: menu that opens a (course-specific) web page. 3. Replace "icon.png" in your renamed directory with a new 32x32 - icon. This icon is displayed on startup with DrScheme's splash - screen, and it is included at half size on the "Handin" - button. Again, choose a distinct icon for the benefit of - students who install multiple handin tools. + icon. This icon is displayed on startup with DrScheme's splash + screen, and it is included at half size on the "Handin" button. + Again, choose a distinct icon for the benefit of students who + install multiple handin tools. 4. Replace "server-cert.pem" in your renamed directory with a - server certificate. The file "server-cert.pem" in + server certificate. The file "server-cert.pem" in "handin-client" collection is ok for testing, but the point of this certificate is to make handins secure, so you should generate a new (self-certifying) certificate and keep its key - private. (See server setup, below.) + private. (See server setup, below.) 5. Run mzc --collection-plt .plt @@ -139,9 +139,9 @@ To customize the client: (i.e., whatever you changed "handin-client" to). 6. Distribute .plt to students for installation into their - copies of DrScheme. The students need not have access to the + copies of DrScheme. The students need not have access to the DrScheme installation directory; the tool will be installed on - the filesystem in the student's personal space. If you want to + the filesystem in the student's personal space. If you want to install it once on a shared installation, use setup-plt with the --all-users flag. @@ -150,18 +150,19 @@ Server Setup ============================================ The server must be run from a directory that is specially prepared to -host the server. This directory contains the following files and +host the server. This directory contains the following files and sub-directories: - * "server-cert.pem" --- the server's certificate. To create a + * "server-cert.pem" --- the server's certificate. To create a certificate and key with openssl: - openssl req -new -nodes -x509 -days 365 -out server-cert.pem - -keyout private-key.pem + openssl req -new -nodes -x509 -days 365 -out server-cert.pem + -keyout private-key.pem - * "private-key.pem" --- the private key to go with "server-cert.pem". - Whereas "server-cert.pem" gets distributed to students with the - handin client, "private-key.pem" is kept private. + * "private-key.pem" --- the private key to go with + "server-cert.pem". Whereas "server-cert.pem" gets distributed to + students with the handin client, "private-key.pem" is kept + private. * "config.ss" (optional) --- configuration options. The file format is @@ -280,7 +281,7 @@ sub-directories: the list of user accounts, along with the associated password (actually the MD5 hash of the password), and extra string fields as specified by the 'extra-fields configuration entry (in the same - order). The file format is + order). The file format is (( ( ...)) ...) @@ -291,13 +292,13 @@ sub-directories: ...) Username that begin with "solution" are special. They are used by - the HTTPS status server. Independent of the 'user-regexp and + the HTTPS status server. Independent of the 'user-regexp and 'username-case-sensitive? configuration items, usernames are not allowed to contain characters that are illegal in Windows pathnames, they cannot end or begin in spaces or periods. If the 'allow-new-users configuration allows new users, the - "users.ss" file can be updated by the server with new users. It + "users.ss" file can be updated by the server with new users. It can always be updated by the server to change passwords. If you have access to a standard Unix password file (from @@ -314,12 +315,12 @@ sub-directories: system file: foo:wRzN1u5q2SqRD:1203:1203:L.E. Foo:/home/foo:/bin/tcsh - bar:$1$dKlU0OkJ$t63NU/eTzKz:1205:1205:Bar Z. Lie:/home/bar:/bin/bash + bar:$1$dKlU0OkJ$t63TzKz:1205:1205:Bar Z. Lie:/home/bar:/bin/bash you can create this "users.ss" file: ((foo ((unix "wRzN1u5q2SqRD") "L.E. Foo" "?")) - (bar ((unix "$1$dKlU0OkJ$t63NU/eTzKz") "Bar Z. Lie" "?"))) + (bar ((unix "$1$dKlU0OkJ$t63TzKz") "Bar Z. Lie" "?"))) which can be combined with this setting for 'extra-fields in your "config.ss": @@ -477,34 +478,36 @@ sub-directories: The server can be run within either MzScheme or MrEd, but "utils.ss" requires MrEd (which means that `checker' modules will likely require -the server to run under MrEd). +the server to run under MrEd). It is best to use MrEd3m so memory +accounting is possible and the server will be protected from memory +related crashes. The server currently provides no mechanism for a graceful shutdown, -but terminating the server is no worse than a network outage. (In -particular, no data should be lost.) To reconfigure the server (e.g., +but terminating the server is no worse than a network outage. (In +particular, no data should be lost.) To reconfigure the server (e.g., to change the set of active assignments), stop it and restart it. The client and server are designed to be robust against network -problems and timeouts. The client-side tool always provides a "cancel" -button for any network transaction. For handins, "cancel" is +problems and timeouts. The client-side tool always provides a +"cancel" button for any network transaction. For handins, "cancel" is guaranteed to work up to the point that the client sends a "commit" command; this command is sent only after the server is ready to record the submission (having run it through the checker, if any), but before -renaming "ATTEMPT". Also, the server responds to a commit with "ok" -only after it has written the file. Thus, when the client-side tool -reports that the handin was successful, the report is -reliable. Meanwhile, the tool can also report successful cancels most -of the time. In the (normally brief) time between a commit and an "ok" +renaming "ATTEMPT". Also, the server responds to a commit with "ok" +only after it has written the file. Thus, when the client-side tool +reports that the handin was successful, the report is reliable. +Meanwhile, the tool can also report successful cancels most of the +time. In the (normally brief) time between a commit and an "ok" response, the tool gives the student a suitable warning that the cancel is unreliable. To minimize human error, the number of active assignments should be -limited to one whenever possible. When multiple assignments are +limited to one whenever possible. When multiple assignments are active, design a checker to help ensure that the student has selected the correct assignment in the handin dialog. A student can download his/her own submissions through a web server -that runs concurrently with the handin server. The starting URL is +that runs concurrently with the handin server. The starting URL is https://SERVER:PORT/servlets/status.ss @@ -512,7 +515,7 @@ to obtain a list of all assignments, or https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT -to start with a specific assignment (named ASSIGNMENT). The default +to start with a specific assignment (named ASSIGNMENT). The default PORT is 7980. @@ -522,14 +525,15 @@ Checker Utilities The _utils.ss_ module provides utilities helpful in implementing `checker' functions: -> (unpack-submission bytes) - returns two text% objects corresponding - to the submitted definitions and interactions windows. +> (unpack-submission bytes) + Returns two text% objects corresponding to the submitted definitions + and interactions windows. -> (make-evaluator language teachpack-paths program-port) - returns a - function of one required argument for evaluating expressions in the - designated language, and loading teachpacks that are specified in - `teachpack-paths'. The `program-port' is an input port that - produces the content of the definitions window; use +> (make-evaluator language teachpack-paths program-port) + Returns a function of one required argument for evaluating + expressions in the designated language, and loading teachpacks that + are specified in `teachpack-paths'. The `program-port' is an input + port that produces the content of the definitions window; use `(open-input-string "")' for an empty definitions window. The `language' can be: @@ -557,114 +561,118 @@ The _utils.ss_ module provides utilities helpful in implementing that retrieve additional information. Currently, only 'execute-counts is used (see below). -> (make-evaluator/submission language teachpack-paths bytes) - like - `make-evaluator', but the definitions content is supplied as a +> (make-evaluator/submission language teachpack-paths bytes) + Like `make-evaluator', but the definitions content is supplied as a submission byte string. The byte string is opened for reading, with line-counting enabled. -> (call-with-evaluator language teachpack-paths program-port proc) - - calls `proc' with an evaluator for the given language, teachpack - paths, and initial definition content as supplied by a port. It also - sets the current error-value print handler to print values in a way - suitable for `lang', it initializes `current-run-status' with +> (call-with-evaluator language teachpack-paths program-port proc) + Calls `proc' with an evaluator for the given language, teachpack + paths, and initial definition content as supplied by a port. It + also sets the current error-value print handler to print values in a + way suitable for `lang', it initializes `current-run-status' with "executing your code", and it catches all exceptions to re-raise them in a form suitable as a submission error. -> (call-with-evaluator/submission language teachpack-paths bytes proc) - - like `call-with-evaluator', but the definitions content is supplied - as a submission string. The byte string is opened for reading, - with line-counting enabled. +> (call-with-evaluator/submission language teachpack-paths bytes proc) + Like `call-with-evaluator', but the definitions content is supplied + as a submission string. The byte string is opened for reading, with + line-counting enabled. +> (evaluate-all source input-port eval) + Like `load' on an input port. -> (evaluate-all source input-port eval) - like `load' on an input - port. +> (evaluate-submission bytes eval) + Like `load' on a non-test-suite submission byte string. -> (evaluate-submission bytes eval) - like `load' on a non-test-suite - submission byte string. +> coverage-enabled + Parameter that controls whether coverage testing is enabled. If it + set to true, the errortrace collection will be used to collect + coverage information during evaluation of the submission, this + information is collected before additional checker-evaluations. To + retrieve the collected information, apply the evaluation function + with a second argument of 'execute-counts (the first argument will + be ignored). The resulting value is the same as the result of + errortrace's `get-execute-counts', with all non-submission entries + filtered out. - -> coverage-enabled - parameter that controls whether coverage testing - is enabled. If it set to true, the errortrace collection will be - used to collect coverage information during evaluation of the - submission, this information is collected before additional - checker-evaluations. To retrieve the collected information, apply - the evaluation function with a second argument of 'execute-counts - (the first argument will be ignored). The resulting value is the - same as the result of errortrace's `get-execute-counts', with all - non-submission entries filtered out. - - -> (check-proc eval expect-v compare-proc proc-name arg ...) - calls - the function named `proc-name' using the evaluator `eval', giving it - the (unquoted) arguments `arg'... Let `result-v' be the result of - the call; unless `(compare-proc result-v expect-v)' is true, an - exception is raised. +> (check-proc eval expect-v compare-proc proc-name arg ...) + Calls the function named `proc-name' using the evaluator `eval', + giving it the (unquoted) arguments `arg'... Let `result-v' be the + result of the call; unless `(compare-proc result-v expect-v)' is + true, an exception is raised. Every exception or result mismatch during the call to `check-proc' phrased suitably for the handin client. -> (check-defined eval name) - checks whether `name' is defined in the - evaluator `eval', and raises an error if not (suitably phrased for - the handin client). If it is defined as non-syntax, its value is - returned. Warning: in the beginner language level, procedure - definitions are bound as syntax. +> (check-defined eval name) + Checks whether `name' is defined in the evaluator `eval', and raises + an error if not (suitably phrased for the handin client). If it is + defined as non-syntax, its value is returned. Warning: in the + beginner language level, procedure definitions are bound as syntax. -> (look-for-tests text name n) - inspects the given text% object to - determine whether it contains at least `n' tests for the function - `name'. The tests must be top-level expressions. +> (look-for-tests text name n) + Inspects the given text% object to determine whether it contains at + least `n' tests for the function `name'. The tests must be + top-level expressions. -> (user-construct eval name arg ...) - like `check-proc', but with no - result checking. This function is often useful for calling a - student-defined constructor. +> (user-construct eval name arg ...) + Like `check-proc', but with no result checking. This function is + often useful for calling a student-defined constructor. +> test-history-enabled + Parameter that controls how run-time errors are reported to the + handin client. If the parameter's value is true, then the complete + sequence of tested expressions is reported to the handin client for + any test failure. Set this parameter to true when testing programs + that use state. -> test-history-enabled - parameter that controls how run-time errors - are reported to the handin client. If the parameter's value is true, - then the complete sequence of tested expressions is reported to the - handin client for any test failure. Set this parameter to true when - testing programs that use state. +> (message string [styles]) + If given only a string, this string will be shown on the client's + submission dialog; if `styles' is also given, it can be the symbol + 'final, which will be used as the text on the handin dialog after a + successful submission instead of "Handin successful." (useful for + submissions that were saved, but had problems); finally, `styles' + can be used as a list of styles for a `message-box' dialog on the + client side, and the resulting value is returned as the result of + `message'. You can use that to send warnings to the student and + wait for confirmation. -> (message string [styles]) - if given only a string, this string will - be shown on the client's submission dialog; if `styles' is also - given, it can be the symbol 'final, which will be used as the text - on the handin dialog after a successful submission instead of - "Handin successful." (useful for submissions that were saved, but - had problems); finally, `styles' can be used as a list of styles for - a `message-box' dialog on the client side, and the resulting value - is returned as the result of `message'. You can use that to send - warnings to the student and wait for confirmation. +> (current-run-status string-or-#f) + Registers information about the current actions of the checker, in + case the session is terminated due to excessive memory consumption. + For example, a checker might set the status to indicate which + instructor-supplied test was being executed when the session ran out + of memory. This status is only used when per-session memory limits + are supported (i.e., under MrEd3m or MzScheme3m with memory + accounting), but in both cases, a string value will also be passed + on to `message' above. -> (current-run-status string-or-#f) - registers information about the - current actions of the checker, in case the session is terminated - due to excessive memory consumption. For example, a checker might - set the status to indicate which instructor-supplied test was being - executed when the session ran out of memory. This status is only - used when per-session memory limits are supported (i.e., under - MrEd3m or MzScheme3m with memory accounting), but in both cases, a - string value will also be passed on to `message' above. +> (current-value-printer proc) + A parameter that controls how values are printed, a procedure that + expects a Scheme value and returns a string representation for it. + The default value printer uses pretty-print, with DrScheme-like + settings. -> (current-value-printer proc) - a parameter that controls how values - are printed, a procedure that expects a Scheme value and returns a - string representation for it. The default value printer uses - pretty-print, with DrScheme-like settings. +> (reraise-exn-as-submission-problem thunk) + Calls thunk in a context that catches exceptions and re-raises them + in a form suitable as a submission error. -> (reraise-exn-as-submission-problem thunk) - calls thunk in a context - that catches exceptions and re-raises them in a form suitable as a - submission error. +> (log-line fmt args ...) + Produces a line in the server log file, using the given format + string and arguments. All this actually does, is arrange to print + the line fast (to avoid mixing lines from different threads) to the + error port, and flush it. - -> (LOG fmt args ...) - produces a line in the server log file, using - the given format string and arguments. - -> (timeout-control msg) - control the timeout for this session. The - timeout is initialized by the value of the 'session-timeout - configuration entry, and the checker can use this procedure to - further control it: if msg is 'reset the timeout is reset to - 'session-timeout seconds; if msg is a number the timeout will be set - to that many seconds in the future. The timeout can be completely - disabled by (timeout-control #f). (Note that before the checker is - used (after the pre-checker, if specified), the timer will be reset - to the 'session-timeout value.) +> (timeout-control msg) + Control the timeout for this session. The timeout is initialized by + the value of the 'session-timeout configuration entry, and the + checker can use this procedure to further control it: if msg is + 'reset the timeout is reset to 'session-timeout seconds; if msg is a + number the timeout will be set to that many seconds in the future. + The timeout can be completely disabled by (timeout-control #f). + (Note that before the checker is used (after the pre-checker, if + specified), the timer will be reset to the 'session-timeout value.) Extra Checker Utilities @@ -780,10 +788,10 @@ Keywords for configuring `check:': additional tests). It can be a plain string which will be used as the error message, or a string with single a "~a" (or "~e", "~s", "~v") that will be used as a format string with the actual error - message. The default is "Error in your code --\n~a". Examples of - these: + message. The default is "Error in your code --\n~a". Useful + examples of these messages: - "there is an error in your program, hit \"Run\" and debug your code" + "There is an error in your program, hit \"Run\" to debug" "There is an error in your program:\n----\n~a\n----\n Hit \"Run\" and debug your code." @@ -798,8 +806,10 @@ Keywords for configuring `check:': (message (string-append "You have an error in your program -- please hit" " \"Run\" and debug your code.\n" - "Email the course staff if you think your code is fine.\n" - "(The submission has been saved but marked as erroneous.)") + "Email the course staff if you think your code is" + " fine.\n" + "(The submission has been saved but marked as" + " erroneous.)") '(ok)) (message "Handin saved as erroneous." 'final)) @@ -841,7 +851,7 @@ value from the submission code. (file-size "hw.scm") (file-or-directory-modify-seconds "hw.scm"))) (timeout-control 'disable) - (LOG "Sending a receipt: ~a" info) + (log-line "Sending a receipt: ~a" info) (send-mail-message "course-staff@university.edu" "Submission Receipt" diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 20191abe5b..640913bd3f 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -8,12 +8,12 @@ (lib "string.ss") "private/md5.ss" "private/lock.ss" - "web-status-server.ss" - "run-status.ss") + "private/logger.ss" + "private/run-status.ss" + "web-status-server.ss") - (define log-port (open-output-file "log.ss" 'append)) - - (define current-session (make-parameter 0)) + ;; !!! (define log-port (open-output-file "log.ss" 'append)) + (install-logger-port) (define (write+flush port . xs) (for-each (lambda (x) (write x port) (newline port)) xs) @@ -29,19 +29,6 @@ [(pair? default) (car default)] [else (error (alist-name alist) "no value for `~s'" key)])) - (provide LOG) - (define (LOG str . args) - ;; Assemble log into into a single string, to make - ;; interleaved log lines unlikely: - (let ([line - (format "(~a ~s ~s)\n" - (current-session) - (parameterize ([date-display-format 'iso-8601]) - (date->string (seconds->date (current-seconds)) #t)) - (apply format str args))]) - (display line log-port) - (flush-output log-port))) - (define server-dir (current-directory)) (define config-file (build-path server-dir "config.ss")) @@ -118,8 +105,8 @@ [dir (and (pair? dir) (car dir))]) (when dir (unless (member dir SUCCESS-GOOD) - (LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a" - (build-path (current-directory) dir))) + (log-line "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a" + (build-path (current-directory) dir))) ;; We have a submission directory -- copy all newer things (extra ;; things that exist in the main submission directory but not in ;; SUCCESS, or things that are newer in the main submission @@ -148,14 +135,14 @@ ;; exclusive access to the directory contents. (with-handlers ([void (lambda (e) - (LOG "*** ERROR DURING (cleanup-submission ~s) : ~a" - dir (if (exn? e) (exn-message e) e)))]) + (log-line "*** ERROR DURING (cleanup-submission ~s) : ~a" + dir (if (exn? e) (exn-message e) e)))]) (when (directory-exists? dir) ; submissions can fail before mkdir (parameterize ([current-directory dir]) (call-with-semaphore cleanup-sema cleanup-submission-body))))) (define (cleanup-all-submissions) - (LOG "Cleaning up all submission directories") + (log-line "Cleaning up all submission directories") (for-each (lambda (top) (when (directory-exists? top) (parameterize ([current-directory top]) @@ -210,7 +197,7 @@ (define len #f) (unless (member assignment assignments) (error 'handin "not an active assignment: ~a" assignment)) - (LOG "assignment for ~a: ~a" users assignment) + (log-line "assignment for ~a: ~a" users assignment) (write+flush w 'ok) (set! len (read r-safe)) (unless (and (number? len) (integer? len) (positive? len)) @@ -262,7 +249,7 @@ (make-directory ATTEMPT-DIR) (save-submission s (build-path ATTEMPT-DIR "handin")) (timeout-control 'reset) - (LOG "checking ~a for ~a" assignment users) + (log-line "checking ~a for ~a" assignment users) (let* ([checker* (path->complete-path (build-path 'up "checker.ss"))] [checker* (and (file-exists? checker*) (parameterize ([current-directory server-dir]) @@ -298,7 +285,7 @@ (let ([v (read (make-limited-input-port r 50))]) (if (eq? v 'check) (begin - (LOG "saving ~a for ~a" assignment users) + (log-line "saving ~a for ~a" assignment users) (parameterize ([current-directory ATTEMPT-DIR]) (cond [part (unless (equal? part "handin") (rename-file-or-directory "handin" part))] @@ -325,7 +312,7 @@ (error 'handin "not an active assignment: ~a" assignment)) (unless (directory-exists? submission-dir) (error 'handin "no ~a submission directory for ~a" assignment users)) - (LOG "retrieving assignment for ~a: ~a" users assignment) + (log-line "retrieving assignment for ~a: ~a" users assignment) (parameterize ([current-directory (build-path "active" assignment dirname)]) (define magics '(#"WXME" #"<<>>")) (define mlen (apply max (map bytes-length magics))) @@ -419,7 +406,7 @@ (lambda (str info) (check-field str (cadr info) (car info) (caddr info))) extra-fields EXTRA-FIELDS) (wait-for-lock "+newuser+") - (LOG "create user: ~a" username) + (log-line "create user: ~a" username) (put-user-data username (cons passwd extra-fields))) (define (change-user-info data) @@ -442,8 +429,8 @@ (for-each (lambda (str info) (check-field str (cadr info) (car info) (caddr info))) (cdr new-data) EXTRA-FIELDS) - (LOG "change info for ~a ~s -> ~s" - (car usernames) (car user-datas) new-data) + (log-line "change info for ~a ~s -> ~s" + (car usernames) (car user-datas) new-data) (put-user-data (car usernames) new-data))) (define (get-user-info data) @@ -466,7 +453,7 @@ (define (has-password? raw md5 passwords) (define (good? passwd) (define (bad-password msg) - (LOG "ERROR: ~a -- ~s" msg passwd) + (log-line "ERROR: ~a -- ~s" msg passwd) (error 'handin "bad password in user database")) (cond [(string? passwd) (equal? md5 passwd)] [(and (list? passwd) (= 2 (length passwd)) @@ -552,10 +539,10 @@ (a-ref data 'raw-password) (a-ref data 'password) (cons MASTER-PASSWD (map car user-datas))))) - (LOG "failed login: ~a" (a-ref data 'username/s)) + (log-line "failed login: ~a" (a-ref data 'username/s)) (error 'handin "bad username or password for ~a" (a-ref data 'username/s))) - (LOG "login: ~a" usernames)) + (log-line "login: ~a" usernames)) (case msg [(change-user-info) (change-user-info data)] [(save-submission) (accept-specific-submission data r r-safe w)] @@ -574,7 +561,7 @@ (define current-timeout-control (make-parameter #f)) (provide timeout-control) (define (timeout-control msg) - (LOG "timeout-control: ~s" msg) + (log-line "timeout-control: ~s" msg) ((current-timeout-control) msg)) (define (with-watcher w proc) @@ -595,7 +582,7 @@ (with-handlers ([exn:fail:unsupported? (lambda (x) (set! no-limit-warning? #t) - (LOG "WARNING: per-session memory limit not supported by MrEd"))]) + (log-line "WARNING: per-session memory limit not supported by MrEd"))]) (custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust))) (let* ([watcher (parameterize ([current-custodian orig-custodian]) @@ -609,9 +596,9 @@ [status (if status (format " while ~a" status) "")]) - (LOG "session killed ~a~a" - (if timed-out? "(timeout) " "(memory)") - status) + (log-line "session killed ~a~a" + (if timed-out? "(timeout) " "(memory)") + status) (write+flush w (format "handin terminated due to ~a (program doesn't terminate?)~a" (if timed-out? "time limit" "excessive memory use") @@ -627,12 +614,12 @@ (loop #t)] [else (collect-garbage) - (LOG "running ~a ~a" - (current-memory-use session-cust) - (if no-limit-warning? - "(total)" - (list (current-memory-use orig-custodian) - (current-memory-use)))) + (log-line "running ~a ~a" + (current-memory-use session-cust) + (if no-limit-warning? + "(total)" + (list (current-memory-use orig-custodian) + (current-memory-use)))) (loop #f)]))))))]) ;; Run proc in a thread under session-cust: (let ([session-thread @@ -652,26 +639,24 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (LOG "server started ------------------------------") + (log-line "server started ------------------------------") (define stop-status (serve-status HTTPS-PORT-NUMBER get-config)) (define session-count 0) - (parameterize ([error-display-handler - (lambda (msg exn) - (LOG msg))]) + (parameterize ([error-display-handler (lambda (msg exn) (log-line msg))]) (run-server PORT-NUMBER (lambda (r w) (set! connection-num (add1 connection-num)) (when ((current-memory-use) . > . SESSION-MEMORY-LIMIT) (collect-garbage)) - (parameterize ([current-session (begin - (set! session-count (add1 session-count)) - session-count)]) + (parameterize ([current-session + (begin (set! session-count (add1 session-count)) + session-count)]) (let-values ([(here there) (ssl-addresses r)]) - (LOG "connect from ~a" there)) + (log-line "connect from ~a" there)) (with-watcher w (lambda (kill-watcher) @@ -681,10 +666,10 @@ (with-handlers ([exn:fail? (lambda (exn) (let ([msg (if (exn? exn) - (exn-message exn) - (format "~e" exn))]) + (exn-message exn) + (format "~e" exn))]) (kill-watcher) - (LOG "ERROR: ~a" msg) + (log-line "ERROR: ~a" msg) (write+flush w msg) ;; see note on close-output-port below (close-output-port w)))]) @@ -693,14 +678,14 @@ (write+flush w 'ver1) (error 'handin "unknown protocol: ~s" protocol))) (handle-connection r r-safe w) - (LOG "normal exit") + (log-line "normal exit") (kill-watcher) ;; This close-output-port should not be necessary, and it's - ;; here due to a deficiency in the SLL binding. - ;; The problem is that a custodian shutdown of w is harsher - ;; for SSL output than a normal close. A normal close - ;; flushes an internal buffer that's not supposed to exist, while - ;; the shutdown gives up immediately. + ;; here due to a deficiency in the SLL binding. The problem is + ;; that a custodian shutdown of w is harsher for SSL output + ;; than a normal close. A normal close flushes an internal + ;; buffer that's not supposed to exist, while the shutdown + ;; gives up immediately. (close-output-port w))))))) #f ; `with-watcher' handles our timeouts (lambda (exn) diff --git a/collects/handin-server/private/logger.ss b/collects/handin-server/private/logger.ss new file mode 100644 index 0000000000..931166fd5b --- /dev/null +++ b/collects/handin-server/private/logger.ss @@ -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))))) diff --git a/collects/handin-server/run-status.ss b/collects/handin-server/private/run-status.ss similarity index 100% rename from collects/handin-server/run-status.ss rename to collects/handin-server/private/run-status.ss diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index 3896837060..698f9670f1 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -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 @@ (stringstring (bytes-length data))) - ,@(if wxme? - `((Content-Disposition - . - ,(format "attachment; filename=~s" - (let-values ([(base name dir?) (split-path file)]) - (path->string name))))) - '())) - (list data))))) + (cond [html? #"text/html"] + [wxme? #"application/data"] + [else #"text/plain"]) + `((Content-Length . ,(number->string (bytes-length data))) + (Content-Disposition + . ,(format "~a; filename=~s" + (if wxme? "attachment" "inline") + (let-values ([(base name dir?) + (split-path file)]) + (path->string name))))) + (list data))))) (define (status-page status for-handin) (if for-handin diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index fa444e590c..d16fc7aa24 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -1,47 +1,46 @@ (module utils mzscheme (require (lib "class.ss") - (lib "mred.ss" "mred") - (lib "posn.ss" "lang") - "run-status.ss" - (prefix pc: (lib "pconvert.ss")) - (lib "pretty.ss") - (lib "list.ss") - (lib "string.ss") - (only "handin-server.ss" LOG timeout-control)) + (lib "mred.ss" "mred") + (lib "posn.ss" "lang") + "private/run-status.ss" + (prefix pc: (lib "pconvert.ss")) + (lib "pretty.ss") + (lib "list.ss") + (lib "string.ss") + (only "handin-server.ss" timeout-control)) (provide unpack-submission - unpack-test-suite-submission - is-test-suite-submission? + unpack-test-suite-submission + is-test-suite-submission? - make-evaluator - make-evaluator/submission - evaluate-all - evaluate-submission + make-evaluator + make-evaluator/submission + evaluate-all + evaluate-submission - call-with-evaluator - call-with-evaluator/submission - reraise-exn-as-submission-problem - current-run-status - message + call-with-evaluator + call-with-evaluator/submission + reraise-exn-as-submission-problem + current-run-status + message current-value-printer - coverage-enabled + coverage-enabled - check-proc - check-defined - look-for-tests - user-construct - test-history-enabled + check-proc + check-defined + look-for-tests + user-construct + test-history-enabled - LOG - timeout-control) + timeout-control) (define (unpack-submission str) (let* ([base (make-object editor-stream-in-bytes-base% str)] - [stream (make-object editor-stream-in% base)] - [definitions-text (make-object text%)] - [interactions-text (make-object text%)]) + [stream (make-object editor-stream-in% base)] + [definitions-text (make-object text%)] + [interactions-text (make-object text%)]) (read-editor-version stream base #t) (read-editor-global-header stream) (send definitions-text read-from-file stream) @@ -51,8 +50,8 @@ (define (unpack-test-suite-submission str) (let* ([base (make-object editor-stream-in-bytes-base% str)] - [stream (make-object editor-stream-in% base)] - [ts (make-object ts-load%)]) + [stream (make-object editor-stream-in% base)] + [ts (make-object ts-load%)]) (read-editor-version stream base #t) (read-editor-global-header stream) (send ts read-from-file stream) @@ -61,21 +60,21 @@ (define (is-test-suite-submission? str) (send (unpack-test-suite-submission str) - got-program?)) + got-program?)) ;; Test Suite Unpacking ---------------------------------------- ;; This code duplicates just enough of the test-suite snips ;; to make test-suite files readable. - + (define program-header-field-name "drscheme:test-suite:program") (define csc (new - (class snip-class% - (define/override (read f) - (let ([case (new case%)]) - (send case read-from-file f) - case)) - (super-new)))) + (class snip-class% + (define/override (read f) + (let ([case (new case%)]) + (send case read-from-file f) + case)) + (super-new)))) (send csc set-classname "case%") (send csc set-version 1) (send (get-the-snip-class-list) add csc) @@ -89,10 +88,10 @@ (define test (new text%)) (define/public (read-from-file f) - (send call read-from-file f) - (send expected read-from-file f) - (send test read-from-file f) - (send f get-string)) + (send call read-from-file f) + (send expected read-from-file f) + (send test read-from-file f) + (send f get-string)) (super-new) @@ -102,12 +101,12 @@ (send (get-editor) insert (make-object editor-snip% test)))) (define dsc (new - (class snip-class% - (define/override (read f) - (let ([helper (new helper%)]) - (send helper read-from-file f) - helper)) - (super-new)))) + (class snip-class% + (define/override (read f) + (let ([helper (new helper%)]) + (send helper read-from-file f) + helper)) + (super-new)))) (send dsc set-classname "drscheme:test-suite:helper%") (send dsc set-version 1) (send (get-the-snip-class-list) add dsc) @@ -117,7 +116,7 @@ (inherit set-snipclass get-editor) (define/public (read-from-file f) - (send (get-editor) read-from-file f)) + (send (get-editor) read-from-file f)) (super-new) @@ -131,11 +130,11 @@ (define/public (got-program?) got-p?) (define/override (read-header-from-file stream name) - (if (string=? name program-header-field-name) - (begin - (set! got-p? #t) - (send program read-from-file stream)) - (super read-header-from-file stream name))) + (if (string=? name program-header-field-name) + (begin + (set! got-p? #t) + (send program read-from-file stream)) + (super read-header-from-file stream name))) (super-new))) @@ -177,7 +176,7 @@ (define modules-to-attach (list '(lib "posn.ss" "lang") - '(lib "cache-image-snip.ss" "mrlib"))) + '(lib "cache-image-snip.ss" "mrlib"))) (define (make-evaluation-namespace) (let ([new-ns (make-namespace-with-mred)] @@ -196,19 +195,19 @@ (let ([coverage-enabled (coverage-enabled)] [execute-counts #f] [ns (make-evaluation-namespace)] - [orig-ns (current-namespace)]) + [orig-ns (current-namespace)]) (parameterize ([current-namespace ns] - [read-case-sensitive #t] - [read-decimal-as-inexact #f] - [current-inspector (make-inspector)]) - (parameterize ([current-eventspace (make-eventspace)]) - (let ([ch (make-channel)] - [result-ch (make-channel)]) - (queue-callback - (lambda () - ;; First read program and evaluate it as a module: - (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) - (let* ([body + [read-case-sensitive #t] + [read-decimal-as-inexact #f] + [current-inspector (make-inspector)]) + (parameterize ([current-eventspace (make-eventspace)]) + (let ([ch (make-channel)] + [result-ch (make-channel)]) + (queue-callback + (lambda () + ;; First read program and evaluate it as a module: + (with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))]) + (let* ([body (parameterize ([read-case-sensitive #t] [read-decimal-as-inexact #f]) (let loop ([l null]) @@ -267,22 +266,22 @@ (filter (lambda (x) (eq? 'program (syntax-source (car x)))) (safe-eval '(get-execute-counts) ns)))))) - (channel-put result-ch 'ok)) - ;; Now wait for interaction expressions: - (let loop () - (let ([expr (channel-get ch)]) - (unless (eof-object? expr) - (with-handlers ([void (lambda (exn) - (channel-put result-ch (cons 'exn exn)))]) - (channel-put result-ch (cons 'val (safe-eval expr)))) - (loop)))) - (let loop () - (channel-put result-ch '(exn . no-more-to-evaluate)) - (loop)))) - (let ([r (channel-get result-ch)]) - (if (eq? r 'ok) - ;; Initial program executed ok, so return an evaluator: - (lambda (expr . more) + (channel-put result-ch 'ok)) + ;; Now wait for interaction expressions: + (let loop () + (let ([expr (channel-get ch)]) + (unless (eof-object? expr) + (with-handlers ([void (lambda (exn) + (channel-put result-ch (cons 'exn exn)))]) + (channel-put result-ch (cons 'val (safe-eval expr)))) + (loop)))) + (let loop () + (channel-put result-ch '(exn . no-more-to-evaluate)) + (loop)))) + (let ([r (channel-get result-ch)]) + (if (eq? r 'ok) + ;; Initial program executed ok, so return an evaluator: + (lambda (expr . more) (if (pair? more) (case (car more) [(execute-counts) execute-counts] @@ -294,8 +293,8 @@ (if (eq? (car r) 'exn) (raise (cdr r)) (cdr r)))))) - ;; Program didn't execute: - (raise (cdr r))))))))) + ;; Program didn't execute: + (raise (cdr r))))))))) (define (open-input-text-editor/lines str) (let ([inp (open-input-text-editor str)]) @@ -308,11 +307,11 @@ (define (evaluate-all source port eval) (let loop () (let ([expr (parameterize ([read-case-sensitive #t] - [read-decimal-as-inexact #f]) - (read-syntax source port))]) - (unless (eof-object? expr) - (eval expr) - (loop))))) + [read-decimal-as-inexact #f]) + (read-syntax source port))]) + (unless (eof-object? expr) + (eval expr) + (loop))))) (define (evaluate-submission str eval) (let-values ([(defs interacts) (unpack-submission str)]) @@ -320,10 +319,10 @@ (define (reraise-exn-as-submission-problem thunk) (with-handlers ([void (lambda (exn) - (error - (if (exn? exn) - (exn-message exn) - (format "~s" exn))))]) + (error + (if (exn? exn) + (exn-message exn) + (format "~s" exn))))]) (thunk))) ;; ---------------------------------------- @@ -331,56 +330,56 @@ (define (check-defined e id) (with-handlers ([exn:fail:syntax? void] - [exn:fail:contract:variable? - (lambda (x) - (error - (format - "\"~a\" is not defined, but it must be defined for handin" - (exn:fail:contract:variable-id x))))]) + [exn:fail:contract:variable? + (lambda (x) + (error + (format + "\"~a\" is not defined, but it must be defined for handin" + (exn:fail:contract:variable-id x))))]) (e #`(#,namespace-variable-value '#,id #t)))) (define (mk-args args) (let loop ([l args]) (if (null? l) - "" - (string-append " " (format "~e" (car l)) (loop (cdr l)))))) + "" + (string-append " " (format "~e" (car l)) (loop (cdr l)))))) (define test-history-enabled (make-parameter #f)) (define test-history (make-parameter null)) - + (define (format-history one-test) (if (test-history-enabled) - (format "(begin~a)" - (apply string-append - (map (lambda (s) - (format " ~a" s)) - (reverse (test-history))))) - one-test)) + (format "(begin~a)" + (apply string-append + (map (lambda (s) + (format " ~a" s)) + (reverse (test-history))))) + one-test)) (define (check-proc e result equal? f . args) (let ([test (format "(~a~a)" f (mk-args args))]) (when (test-history-enabled) - (test-history (cons test (test-history)))) - (current-run-status (format "running instructor-supplied test ~a" - (format-history test))) + (test-history (cons test (test-history)))) + (current-run-status (format "running instructor-supplied test ~a" + (format-history test))) (let-values ([(ok? val) - (with-handlers ([void - (lambda (x) - (error - (format "instructor-supplied test ~a failed with an error: ~e" - (format-history test) - (exn-message x))))]) - (let ([val (e `(,f ,@(map value-converter args)))]) - (values (or (eq? 'anything result) - (equal? val result)) - val)))]) - (unless ok? - (error - (format "instructor-supplied test ~a should have produced ~e, instead produced ~e" - (format-history test) - result - val))) - val))) + (with-handlers ([void + (lambda (x) + (error + (format "instructor-supplied test ~a failed with an error: ~e" + (format-history test) + (exn-message x))))]) + (let ([val (e `(,f ,@(map value-converter args)))]) + (values (or (eq? 'anything result) + (equal? val result)) + val)))]) + (unless ok? + (error + (format "instructor-supplied test ~a should have produced ~e, instead produced ~e" + (format-history test) + result + val))) + val))) (define (user-construct e func . args) (apply check-proc e func 'anything eq? args)) @@ -388,50 +387,50 @@ (define (look-for-tests t name count) (let ([p (open-input-text-editor/lines t)]) (let loop ([found 0]) - (let ([e (read p)]) - (if (eof-object? e) - (when (found . < . count) - (error (format "found ~a test~a for ~a, need at least ~a test~a" - found - (if (= found 1) "" "s") - name - count - (if (= count 1) "" "s")))) - (loop (+ found - (if (and (pair? e) - (eq? (car e) name)) - 1 - 0)))))))) + (let ([e (read p)]) + (if (eof-object? e) + (when (found . < . count) + (error (format "found ~a test~a for ~a, need at least ~a test~a" + found + (if (= found 1) "" "s") + name + count + (if (= count 1) "" "s")))) + (loop (+ found + (if (and (pair? e) + (eq? (car e) name)) + 1 + 0)))))))) (define list-abbreviation-enabled (make-parameter #f)) (define (value-converter v) (parameterize ([pc:booleans-as-true/false #t] - [pc:abbreviate-cons-as-list (list-abbreviation-enabled)] - [pc:constructor-style-printing #t]) + [pc:abbreviate-cons-as-list (list-abbreviation-enabled)] + [pc:constructor-style-printing #t]) (pc:print-convert v))) (define (default-value-printer v) (parameterize ([pretty-print-show-inexactness #t] - [pretty-print-.-symbol-without-bars #t] - [pretty-print-exact-as-decimal #t] - [pretty-print-columns +inf.0] - [read-case-sensitive #t]) + [pretty-print-.-symbol-without-bars #t] + [pretty-print-exact-as-decimal #t] + [pretty-print-columns +inf.0] + [read-case-sensitive #t]) (let ([p (open-output-string)]) - (pretty-print (value-converter v) p) - (regexp-replace #rx"\n$" (get-output-string p) "")))) + (pretty-print (value-converter v) p) + (regexp-replace #rx"\n$" (get-output-string p) "")))) (define current-value-printer (make-parameter default-value-printer)) (define (call-with-evaluator lang teachpacks program-port go) (parameterize ([error-value->string-handler (lambda (v s) - ((current-value-printer) v))] - [list-abbreviation-enabled (not (or (eq? lang 'beginner) - (eq? lang 'beginner-abbr)))]) + ((current-value-printer) v))] + [list-abbreviation-enabled (not (or (eq? lang 'beginner) + (eq? lang 'beginner-abbr)))]) (reraise-exn-as-submission-problem (lambda () - (let ([e (make-evaluator lang teachpacks program-port)]) - (current-run-status "executing your code") - (go e)))))) + (let ([e (make-evaluator lang teachpacks program-port)]) + (current-run-status "executing your code") + (go e)))))) (define (call-with-evaluator/submission lang teachpacks str go) (let-values ([(defs interacts) (unpack-submission str)])