diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 7153601eb4..bb0ee4b939 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -417,7 +417,9 @@ sub-directories: from the status interface. The checker should return a string, such as "handin.scm", to use - in naming the submission 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). Alternatively, the module can bind `checker' to a list of three procedures: a pre-checker, a checker, and a post-checker. All @@ -739,7 +741,15 @@ Keywords for configuring `check:': * :output -- the name of the original handin file (unrelated to the text-converted files). Defaults to "hw.scm". (The suffix changes - the defaults of the following two entries.) + the defaults of the following two entries.) Can be #f for removing + the original file after processing. + +* :multi-file -- by default, this is set to #f, which means that only + DrScheme is used to send submissions as usual. See "Multiple-file + submissions" below for setting up multi-file submissions. + +* :names-checker -- used for multi-file submissions; see + "Multiple-file submissions" below for details. * :markup-prefix -- used as the prefix for :student-lines and :extra-lines below. The default is ";;> " or "//> ", depending on @@ -927,3 +937,45 @@ value from the submission code. error with source information if some code is left uncovered. The collected information includes only execution coverage by submission code, excluding additional checker tests. + +*** Multiple-file submissions + +By default, the system is set up for submissions of single a single +file, straight fom DrScheme using the handin-client. There is some +support for multi-file submissions in "extra-utils.ss" and in the +handin-client -- it is possible to submit multiple files, and have the +system generate a single file that is the concatenation of all +submission files (used only with text files). To set up multi-file +submissions, do the following: + +* Add a `:multi-file' keyword in `check:', and as a value, use the + suffix that should be used for the single concatenated output file. + +* You can also add a `:names-checker' keyword -- the value can be a + regexp that all submitted files must follow (eg, ".*[.]scm$"). + Alternatively, it can be a 1-argument procedure that will receive + the (sorted) list of submitted files and can throw an error if some + files are missing or some files are forbidden. + +* In the "info.ss" file of the handin-client you need to set + `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.) + +On the server side, each submission is saved in a file called "raw", +which contains all submitted files. In the "grading" directory, you +will get a "text." file ("" is the suffix that is used as a +value for `:multi-file') that contains all submitted files with clear +separators. On the client side, students will have an additional +file-menu entry for submitting multiple files, which pops up a dialog +that can be used to submit multiple files. In this dialog, students +choose their working directory, and the `selection-default' entry from +the "handin-client/info.ss" file specifies a few patterns that can be +used to automatically select files. + +The dialog provides all handin-related functionality that is available +in DrScheme. For further convenience, it can be used as a standalone +application: in the account management dialog, the "Un/Install" tab +has a button that will ask for a directory where it will create an +executable for the multi-file submission utility -- the resulting +executable can be used outside of DrScheme. diff --git a/collects/handin-server/extra-utils.ss b/collects/handin-server/extra-utils.ss index 453100c811..a078409187 100644 --- a/collects/handin-server/extra-utils.ss +++ b/collects/handin-server/extra-utils.ss @@ -67,9 +67,10 @@ (let ([line (bytes->string/utf-8 line)]) (unless (or (< (string-length line) len) (< (string-width line) len)) - (error* "~a \"~a\" is longer than ~a characters" + (error* "~a \"~a\" in ~a is longer than ~a characters" (if n (format "Line #~a" n) "The line") (regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1") + (currently-processed-file-name) len))))) ;; ============================================================================ @@ -136,31 +137,48 @@ strs))) (apply bytes-append (reverse! (cons (subbytes str idx) strs))))))) -(define (submission->string submission maxwidth textualize? untabify?) +(define current-processed-file ; set when processing multi-file submissions + (make-parameter #f)) +(define (currently-processed-file-name) + (or (current-processed-file) "your code")) + +(define (input->process->output maxwidth textualize? untabify? bad-re) + (let loop ([n 1]) + (let ([line (if textualize? + (read-bytes-line (current-input-port) 'any) + (with-handlers ([void + (lambda (e) + (error* "The submission must not ~a" + "have non-textual items"))]) + (read-bytes-line (current-input-port) 'any)))]) + (unless (eof-object? line) + (let* ([line (regexp-replace #rx#"[ \t]+$" line #"")] + [line (if (and untabify? + (regexp-match-positions #rx"\t" line)) + (untabify line) line)]) + (when (and bad-re (regexp-match bad-re line)) + (error* "You cannot use \"~a\" in ~a!~a" + (if (regexp? bad-re) (object-name bad-re) bad-re) + (currently-processed-file-name) + (if textualize? "" (format " (line ~a)" n)))) + (when maxwidth + (verify-line-length line (and (not textualize?) n) maxwidth)) + (display line) (newline) (loop (add1 n))))))) + +(define (submission->bytes submission maxwidth textualize? untabify? + markup-prefix bad-re) + (define magic #"WXME") + (unless (equal? magic (subbytes submission 0 (bytes-length magic))) + (error* "bad submission format, expecting a single DrScheme submission")) (let-values ([(defs inters) (unpack-submission submission)]) - (parameterize ([current-output-port (open-output-string)] - [current-input-port + (parameterize ([current-input-port (if textualize? - (input-port->text-input-port - (open-input-text-editor defs 0 'end snip->text)) - (open-input-text-editor defs))]) - (let loop ([n 1]) - (let ([line (if textualize? - (read-bytes-line) - (with-handlers ([void - (lambda (e) - (error* "The submission must not ~a" - "have non-textual items"))]) - (read-bytes-line)))]) - (unless (eof-object? line) - (let* ([line (regexp-replace #rx#"[ \t]+$" line #"")] - [line (if (and untabify? - (regexp-match-positions #rx"\t" line)) - (untabify line) line)]) - (when maxwidth - (verify-line-length line (and (not textualize?) n) maxwidth)) - (display line) (newline) (loop (add1 n)))))) - (get-output-string (current-output-port))))) + (input-port->text-input-port (open-input-text-editor + defs 0 'end snip->text)) + (open-input-text-editor defs))] + [current-output-port (open-output-string)]) + (input->process->output maxwidth textualize? untabify? bad-re) + (get-output-bytes (current-output-port))))) ;; --------------------------------------------------------- ;; This code will hack textualization of test and text boxes @@ -223,6 +241,73 @@ (send text-box-sc set-version 2) (send (get-the-snip-class-list) add text-box-sc) +;; ============================================================================ +;; Dealing with multi-file submissions + +(define ((unpack-multifile-submission names-checker) + submission maxwidth textualize? untabify? + markup-prefix prefix-re) + (define (assert-format b) + (unless b + (error* "bad submission format, expecting a multi-file submission -- ~a" + "use the multi-file submission tool"))) + (let ([files + (parameterize ([current-input-port (open-input-bytes submission)]) + (define magic #"<<>>") + (assert-format (equal? magic (read-bytes (bytes-length magic)))) + (let loop ([files '()]) + (let ([f (with-handlers ([void void]) (read))]) + (if (eof-object? f) + (quicksort files (lambda (x y) (string (lambda (file) (error* "bad filename: ~e" file))]) + ((cond [(procedure? names-checker) names-checker] + [(or (regexp? names-checker) + (string? names-checker) (bytes? names-checker)) + (lambda (names) + (cond [(ormap (lambda (n) + (and (not (regexp-match names-checker n)) n)) + names) + => (lambda (file) (error* "bad filename: ~e" file))]))] + [(not names-checker) void] + [else (error* "bad names-checker specification: ~e" names-checker)]) + (map car files)) + ;; This will create copies of the original files + ;; (for-each (lambda (file) + ;; (with-output-to-file (car file) + ;; (lambda () (display (cadr file)) (flush-output)))) + ;; files) + (let* ([pfx-len (string-length markup-prefix)] + [line-len (- maxwidth pfx-len)] + [=s (lambda (n) (make-string n #\=))] + [=== (format "~a~a\n" markup-prefix (=s line-len))]) + (define (sep name) + (newline) + (display ===) + (let ([n (/ (- line-len 4 (string-length name)) 2)]) + (printf "~a~a< ~a >~a\n" + markup-prefix (=s (floor n)) name (=s (ceiling n)))) + (display ===) + (newline)) + (parameterize ([current-output-port (open-output-bytes)]) + (for-each (lambda (file) + (sep (car file)) + (parameterize ([current-input-port + (open-input-bytes (cadr file))] + [current-processed-file (car file)]) + (input->process->output + maxwidth textualize? untabify? prefix-re))) + files) + (get-output-bytes (current-output-port)))))) + ;; ============================================================================ ;; Checker function @@ -255,16 +340,16 @@ (loop #'(x ...) (cons (list (syntax-e #'key) #'key #'val) keyvals))] [(body ...) (with-syntax - ([users* (get ':users #'#f)] - [eval?* (get ':eval? #'#t)] - [language* (get ':language #'#f)] - [teachpacks* (get ':teachpacks #''())] - [create-text?* (get ':create-text? #'#t)] - [untabify?* (get ':untabify? #'#t)] - [textualize?* (get ':textualize? #'#f)] - [maxwidth* (get ':maxwidth #'79)] + ([users* (get ':users #'#f)] + [eval?* (get ':eval? #'#t)] + [language* (get ':language #'#f)] + [teachpacks* (get ':teachpacks #''())] + [create-text?* (get ':create-text? #'#t)] + [untabify?* (get ':untabify? #'#t)] + [textualize?* (get ':textualize? #'#f)] + [maxwidth* (get ':maxwidth #'79)] [markup-prefix* (get ':markup-prefix #'#f)] - [prefix-re* (get ':prefix-re #'#f)] + [prefix-re* (get ':prefix-re #'#f)] [student-line* (get ':student-line #'"Student: {username} ({Full Name} <{Email}>)")] @@ -272,8 +357,10 @@ (get ':extra-lines #''("Maximum points for this assignment: <+100>"))] [value-printer* (get ':value-printer #'#f)] - [coverage?* (get ':coverage? #'#f)] - [output* (get ':output #'"hw.scm")] + [coverage?* (get ':coverage? #'#f)] + [output* (get ':output #'"hw.scm")] + [multi-file* (get ':multi-file #'#f)] + [names-checker* (get ':names-checker #'#f)] [user-error-message* (get ':user-error-message #'"Error in your code --\n~a")] [checker (id 'checker)] @@ -313,6 +400,8 @@ [value-printer value-printer*] [coverage? coverage?*] [output-file output*] + [multi-file multi-file*] + [names-checker names-checker*] [user-error-message user-error-message*] [execute-counts #f]) ;; ======================================== @@ -320,7 +409,11 @@ (define suffix (let ([sfx (string->symbol (string-downcase - (regexp-replace #rx"^.*[.]" output-file "")))]) + (if multi-file + (format "~a" multi-file) + (and output-file + (regexp-replace + #rx"^.*[.]" output-file "")))))]) (case sfx [(java c cc c++) (unless markup-prefix (set! markup-prefix "//> ")) @@ -357,26 +450,23 @@ (define (write-text) (with-output-to-file text-file (lambda () - (define added (or (thread-cell-ref added-lines) '())) - (for-each - (lambda (user) - (prefix-line (user-substs user student-line))) - users) + (for-each (lambda (user) + (prefix-line + (user-substs user student-line))) + users) (for-each prefix-line extra-lines) - (for-each prefix-line added) + (for-each prefix-line + (or (thread-cell-ref added-lines) '())) (display submission-text)) 'truncate)) (define submission-text (and create-text? - (submission->string - submission maxwidth textualize? untabify?))) - (when create-text? - (make-directory "grading") - (when (regexp-match prefix-re submission-text) - (error* "You cannot use \"~a\" in your code!" - (if (regexp? prefix-re) - (object-name prefix-re) prefix-re))) - (write-text)) + ((if multi-file + (unpack-multifile-submission names-checker) + submission->bytes) + submission maxwidth textualize? untabify? + markup-prefix prefix-re))) + (when create-text? (make-directory "grading") (write-text)) (when value-printer (current-value-printer value-printer)) (when coverage? (coverage-enabled #t)) (current-run-status "checking submission") @@ -434,7 +524,7 @@ "`textualize?' and `coverage?'"] [else #f])]) (when bad - (error* "bad checker specifications: cannot use ~a" bad))) + (error* "bad checker specifications: ~a" bad))) ;; ======================================== (list pre check post))))]))) diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index ec6f46ccd3..8bc97b1a98 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -302,7 +302,9 @@ (begin (LOG "saving ~a for ~a" assignment users) (parameterize ([current-directory ATTEMPT-DIR]) - (rename-file-or-directory "handin" part)) + (cond [part (unless (equal? part "handin") + (rename-file-or-directory "handin" part))] + [(file-exists? "handin") (delete-file "handin")])) ;; Shift successful-attempt directories so that there's ;; no SUCCESS-0: (make-success-dir-available 0) @@ -327,6 +329,8 @@ (error 'handin "no ~a submission directory for ~a" assignment users)) (LOG "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))) (define file ;; find the newest wxme file (let loop ([files (directory-list)] [file #f] [time #f]) @@ -334,8 +338,12 @@ file (let ([f (car files)]) (if (and (file-exists? f) - (equal? #"WXME" (with-input-from-file f - (lambda () (read-bytes 4)))) + (let ([m (with-input-from-file f + (lambda () (read-bytes mlen)))]) + (ormap (lambda (magic) + (equal? magic + (subbytes m 0 (bytes-length magic)))) + magics)) (or (not file) (> (file-or-directory-modify-seconds f) time))) (loop (cdr files) f (file-or-directory-modify-seconds f))