added i/o controlling

svn: r5420

collects/handin-server/doc.txt

@@ -209,7 +209,7 @@ This directory contains the following files and sub-directories:
          "BACKUP-1/handin.scm", etc.; the default is 9
 
       'user-regexp : a regular expression that is used to validate
-         usernames; alternatively, this can be #f meaning no
+         usernames; alternatively, this can be `#f' meaning no
          restriction, or a list of permitted strings.  Young students
          often choose exotic usernames that are impossible to
          remember, and forget capitalization, so the default is fairly
@@ -218,36 +218,36 @@ This directory contains the following files and sub-directories:
          specify joint work
 
       'user-desc : a plain-words description of the acceptable
-         username format (according to user-regexp above); #f stands
+         username format (according to user-regexp above); `#f' stands
          for no description; the default is "alphanumeric string"
          which matches the default user-regexp
 
-      'username-case-sensitive : a boolean; when #f, usernames are
+      'username-case-sensitive : a boolean; when `#f', usernames are
-         case-folded for all purposes; defaults to #f (note that you
+         case-folded for all purposes; defaults to `#f' (note that you
-         should not set this to #t on Windows or when using other
+         should not set this to `#t' on Windows or when using other
          case-insensitive filesystems, since usernames are used as
          directory names)
 
       'allow-new-users : a boolean indicating whether to allow
-         new-user requests from a client tool; the default is #f
+         new-user requests from a client tool; the default is `#f'
 
       'allow-change-info : a boolean indicating whether to allow
          changing user information from a client tool (changing
-         passwords is always possible); the default is #f
+         passwords is always possible); the default is `#f'
 
       'master-password : a string for an MD5 hash for a password that
-         allows login as any user; the default is #f, which disables
+         allows login as any user; the default is `#f', which disables
          the password
 
       'log-output : a boolean that controls whether the handin server
-         log is written on the standard output; defaults to #t
+         log is written on the standard output; defaults to `#t'
 
       'log-file : a path (relative to handin server directory or
          absolute) that specifies a filename for the handin server log
-         (possibly combined with the 'log-output option), or #f for no
+         (possibly combined with the 'log-output option), or `#f' for
-         log file; defaults to "log"
+         no log file; defaults to "log"
 
-      'web-base-dir : if #f (the default), the built-in web server
+      'web-base-dir : if `#f' (the default), the built-in web server
          will use the "status-web-root" in this collection for its
          configuration; to have complete control over the built in
          server, you can copy and edit "status-web-root", and add this
@@ -256,13 +256,13 @@ This directory contains the following files and sub-directories:
 
       'web-log-file : a path (relative to handin server directory or
          absolute) that specifies a filename for logging the internal
-         HTTPS status web server; or #f (the default) to disable this
+         HTTPS status web server; or `#f' (the default) to disable
-         log
+         this log
 
       'extra-fields : a list that describes extra string fields of
          information for student records; each element in this list is
          a list of three values -- the name of the field, the regexp
-         (or #f, or a list of permitted string values), and a string
+         (or `#f', or a list of permitted string values), and a string
          describing of acceptable strings.  The default is
 
            '(("Full Name" #f #f)
@@ -465,7 +465,7 @@ This directory contains the following files and sub-directories:
     hidden from the status interface.
 
     The checker should return a string, such as "handin.scm", to use
-    in naming the submission file, or #f to indicate that he file
+    in naming the submission file, or `#f' to indicate that he file
     should be deleted (eg, when the checker alrady created the
     submission file(s) in a different place).
 
@@ -489,7 +489,7 @@ This directory contains the following files and sub-directories:
       still be in place).  This is useful for things like notifying
       the user of the successful submission (see `message' below), or
       sending a `receipt' email.
-    To specify only pre/post-checker, use #f for the one you want to
+    To specify only pre/post-checker, use `#f' for the one you want to
     omit.
 
   * "<[in]active-assignment>/<user(s)>/<filename>" (if submitted) ---
@@ -607,10 +607,11 @@ by this function.
   (which means that the contents may be unreliable, but the position
   is).  The default is `#f'.
 
-> get-uncovered-expressions
+> (get-uncovered-expressions evaluator)
-  A special value that, when passed to an evaluator created by
+  When this is used with an evaluator that was created with
-  `make-evaluator' or applied on one, will return a list of uncovered
+  `make-evaluator', it will return a list of uncovered syntax
-  syntax objects.
+  objects.  (It can also be provided as an argument to the evaluator,
+  with the same result.)
 
 > namespace-specs
   A parameter that holds a list of values that specify how to create a
@@ -641,6 +642,39 @@ by this function.
   acessing any paths outside of the collection paths, or any kind of
   network activity.
 
+> sandbox-input
+  A parameter that specifies the input for evaluations that happen in
+  a `make-evaluator' function.  It defaults to `#f', which makes such
+  functions work in a context where no input is available.  It can be
+  set to:
+  * an input port, which will be used as is;
+  * a string or a byte string that will be used as the complete input;
+  * a path that names a file holding the input.
+
+> sandbox-output
+  A parameter that specifies the output for evaluations that happen in
+  a `make-evaluator' function.  It defaults to `#f', which simply
+  discards all such output.  It can also be set to:
+  * an output port, which will be used as is;
+  * the symbol 'bytes, which will make `get-output' (see below) return
+    the complete output as a byte string;
+  * the symbol 'string, similar to the above, but uses a string;
+  * the symbol 'pipe, which will make it use a pipe for output, and
+    `get-output' returns the input end of the pipe.
+
+> (get-output evaluator)
+  When this is used with an evaluator that was created with
+  `make-evaluator', it will return the output of the evaluator.  (It
+  can also be provided as an argument to the evaluator, with the same
+  result.)  The result depends on the value of the `sandbox-output'
+  parameter at the time the evaluator was created: if it was `#f' then
+  `get-output' will return `#f', if it was the symbol `pipe' then
+  `get-output' returns an input port that is being fed by the pipe,
+  and if it was the symbol `bytes' or `string' then `get-output'
+  returns the accumulated output and resets the evaluator's output to
+  a new output string or byte string (so each call returns a piece of
+  the evaluator's output).
+
 > (make-evaluator language teachpack-paths input-program)
   This is the main entry point for the sandbox module.
 
@@ -649,14 +683,10 @@ by this function.
   that are specified in `teachpack-paths', and after evaluating the
   code in the `input-program'.
 
-  The `input-program' holds the input program in one of the following
+  The `input-program' holds the input program in the same way as the
-  ways:
+  `sandbox-input' parameter (but it cannot be `#f').  The contents of
-  * an input port that produces the content of the definitions window;
+  this input is read using the `sandbox-reader', with line-counting
-  * a string or a byte string that contains the definitions window
+  enabled.
-    (you can use "" for an empty definitions window);
-  * a path that names a file holding the input program.
-  The contents of the input program is read using the
-  `sandbox-reader', with line-counting enabled.
 
   The `language' can be:
   * a symbol indicating a built-in language (currently, only
@@ -805,7 +835,7 @@ _utils.ss_
   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).
+  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.)
 
@@ -846,10 +876,11 @@ Keywords for configuring `check:':
   useful value for pair submission where the pairs are unknown (see
   below).
 
-* :eval? -- whether submissions should be evaluated.  Defaults to #t.
+* :eval? -- whether submissions should be evaluated.  Defaults to
-  Note that if it is specified as #f, then the checker body will not
+  `#t'.  Note that if it is specified as `#f', then the checker body
-  be able to run any tests on the code, unless it contains code that
+  will not be able to run any tests on the code, unless it contains
-  performs some evaluation (eg, using the facilities of "utils.ss").
+  code that performs some evaluation (eg, using the facilities of
+  "utils.ss").
 
 * :language -- the language that is used for evaluating submissions,
   same as the `language' argument for `make-evaluator' (see above).
@@ -865,30 +896,31 @@ Keywords for configuring `check:':
   that is specified by :output below, for example "hw.java" is
   converted into a textual "grading/text.java").  This is intended for
   printouts and grading, and is in a subdirectory so students will not
-  see it on the status web server.  Defaults to #t.
+  see it on the status web server.  Defaults to `#t'.
 
 * :untabify? -- if true, then tabs are converted to spaces, assuming a
   standard tab width of 8 places.  This is needed for a correct
   computation of line lengths, but note that DrScheme does not insert
-  tabs in Scheme mode.  Defaults to #t.
+  tabs in Scheme mode.  Defaults to `#t'.
 
 * :textualize? -- if true, then all submissions are converted to text,
   trying to convert objects like comment boxes and test cases to some
-  form of text.  Defaults to #f, meaning that an exception is raised
+  form of text.  Defaults to `#f', meaning that an exception is raised
   for submissions that are not all text.
 
 * :maxwidth -- a number that specifies maximum line lengths for
   submissions (a helpful feature for reading student code).  Defaults
-  to 79.  This feature can be disabled if set to #f.
+  to 79.  This feature can be disabled if set to `#f'.
 
 * :output -- the name of the original handin file (unrelated to the
   text-converted files).  Defaults to "hw.scm".  (The suffix changes
-  the defaults of `:markup-prefix' and `:prefix-re' below.)  Can be #f
+  the defaults of `:markup-prefix' and `:prefix-re' below.)  Can be
-  for removing the original file after processing.
+  `#f' for removing the original file after processing.
 
-* :multi-file -- by default, this is set to #f, which means that only
+* :multi-file -- by default, this is set to `#f', which means that
-  DrScheme is used to send submissions as usual.  See "Multiple-file
+  only DrScheme is used to send submissions as usual.  See
-  submissions" below for setting up multi-file submissions.
+  "Multiple-file submissions" below for setting up multi-file
+  submissions.
 
 * :names-checker -- used for multi-file submissions; see
   "Multiple-file submissions" below for details.
@@ -1053,7 +1085,8 @@ value from the submission code.
   have an effect if `:create-text?' is false.
 
 > (procedure/arity? proc arity)
-  Returns #t if `proc' is a procedure that accepts `arity' arguments.
+  Returns `#t' if `proc' is a procedure that accepts `arity'
+  arguments.
 
 > (!defined id ...)
   A macro that checks that the given identifiers are defined in the
@@ -1073,7 +1106,7 @@ value from the submission code.
 > (!test expr)
 > (!test expr result [equal?])
   The first form checks that the given expression evaluates to a
-  non-#f value in the submission context, throwing an error
+  non-`#f' value in the submission context, throwing an error
   otherwise.  The second form compares the result of evaluation,
   requiring it to be equal to `result' (optionally specifying an
   equality procedure).  Note that the `result' and `equal?' forms are
@@ -1113,7 +1146,7 @@ submissions, do the following:
   forbidden.
 
 * In the "info.ss" file of the handin-client you need to set
-  `enable-multifile-handin' to #t, and adjust `selection-default' to
+  `enable-multifile-handin' to `#t', and adjust `selection-default' to
   patterns that are common to your course.  (It can be a single
   pattern, or a list of them.)
 

collects/handin-server/sandbox.ss

@@ -1,11 +1,14 @@
 (module sandbox mzscheme
-  (require (lib "string.ss") (lib "list.ss"))
+  (require (lib "string.ss") (lib "list.ss") (lib "port.ss"))
 
   (provide mred?
            coverage-enabled
            namespace-specs
            sandbox-reader
            sandbox-security-guard
+           sandbox-input
+           sandbox-output
+           get-output
            get-uncovered-expressions
            make-evaluator)
 
@@ -20,6 +23,10 @@
 
   ;; Configuration ------------------------------------------------------------
 
+  (define sandbox-input  (make-parameter #f))
+  (define sandbox-output (make-parameter #f))
+  (define null-input (open-input-bytes #""))
+
   (define coverage-enabled (make-parameter #f))
 
   (define namespace-specs
@@ -63,10 +70,8 @@
           (error what "file access denied (~a)" path)))
       (lambda (what host port mode) (error what "network access denied")))))
 
-  (define null-input (open-input-string ""))
   (define (safe-eval expr)
     (parameterize ([current-security-guard (sandbox-security-guard)]
-                   [current-input-port null-input]
                    ;; breaks: [current-code-inspector (make-inspector)]
                    )
       (eval expr)))
@@ -86,13 +91,15 @@
                     modsyms)))
       new-ns))
 
+  (define (input->port inp)
+    (cond [(input-port? inp) inp]
+          [(string? inp) (open-input-string inp)]
+          [(bytes?  inp) (open-input-bytes inp)]
+          [(path?   inp) (open-input-file inp)]
+          [else (error 'input->port "bad input: ~e" inp)]))
+
   (define (read-code inp)
-    (parameterize ([current-input-port
+    (parameterize ([current-input-port (input->port inp)])
-                    (cond [(input-port? inp) inp]
-                          [(string? inp) (open-input-string inp)]
-                          [(bytes?  inp) (open-input-bytes inp)]
-                          [(path?   inp) (open-input-file inp)]
-                          [else (error 'read-code "bad input: ~e" inp)])])
       (port-count-lines! (current-input-port))
       ((sandbox-reader))))
 
@@ -149,15 +156,39 @@
   (define run-in-bg          (mz/mr thread queue-callback))
 
   (define (get-uncovered-expressions eval) (eval get-uncovered-expressions))
+  (define (get-output eval) (eval get-output))
 
   (define (make-evaluator language teachpacks input-program)
     (let ([coverage-enabled (coverage-enabled)]
           [uncovered-expressions #f]
-          [ns (make-evaluation-namespace)]
           [input-ch  (make-channel)]
-          [result-ch (make-channel)])
+          [result-ch (make-channel)]
-      (parameterize ([current-namespace ns]
+          [output    #f])
-                     [current-inspector (make-inspector)])
+      (parameterize
+          ([current-namespace (make-evaluation-namespace)]
+           [current-inspector (make-inspector)]
+           [current-input-port
+            (let ([inp (sandbox-input)]) (if inp (input->port inp) null-input))]
+           [current-output-port
+            (let ([out (sandbox-output)])
+              (cond [(not out) (open-output-nowhere)]
+                    [(output-port? out) (set! output out) out]
+                    [(eq? out 'pipe)
+                     (let-values ([(i o) (make-pipe)]) (set! output i) o)]
+                    [(memq out '(bytes string))
+                     (let-values
+                         ([(open get)
+                           (if (eq? out 'bytes)
+                             (values open-output-bytes  get-output-bytes)
+                             (values open-output-string get-output-string))])
+                       (let ([o (open)])
+                         (set! output (lambda ()
+                                        (let ([o1 o])
+                                          (set! o (open))
+                                          (current-output-port o)
+                                          (get-output-bytes o1))))
+                         o))]
+                    [else (error 'make-evaluator "bad output: ~e" out)]))])
         ;; Note the above definition of `current-eventspace': in MzScheme, it
         ;; is a parameter that is not used at all.  Also note that creating an
         ;; eventspace starts a thread that will eventually run the callback
@@ -190,16 +221,20 @@
                (channel-put result-ch '(exn . no-more-to-evaluate))
                (loop))))
           (let ([r (channel-get result-ch)])
+            (define (eval-in-user-context expr)
+              (channel-put input-ch expr)
+              (let ([r (channel-get result-ch)])
+                (if (eq? (car r) 'exn) (raise (cdr r)) (apply values (cdr r)))))
             (if (eq? r 'ok)
               ;; Initial program executed ok, so return an evaluator:
               (lambda (expr)
-                (if (eq? expr get-uncovered-expressions)
+                (cond [(eq? expr get-uncovered-expressions)
-                  uncovered-expressions
+                       uncovered-expressions]
-                  (begin (channel-put input-ch expr)
+                      [(eq? expr get-output)
-                         (let ([r (channel-get result-ch)])
+                       (if (procedure? output)
-                           (if (eq? (car r) 'exn)
+                         (eval-in-user-context `(,output))
-                             (raise (cdr r))
+                         output)]
-                             (apply values (cdr r)))))))
+                      [else (eval-in-user-context expr)]))
               ;; Program didn't execute:
               (raise r)))))))