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

add support for message on handin accept, fixed minor GUI bug

Browse Source 
svn: r733
This commit is contained in:
Matthew Flatt 2005-09-01 17:04:49 +00:00
parent 281f9a36b3
commit 76ae386773
5 changed files with 172 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/handin-client/client.ss
View File

@ -55,11 +55,17 @@
(on-commit)
(fprintf w "check\n")
(flush-output w)
(let ([v (read r)])
(unless (eq? v 'done)
(error 'handin-connect "commit probably unsucccesful: ~e" v)))
(close-input-port r)
(close-output-port w)))
(let ([result-msg
(let ([v (read r)])
(cond
[(eq? v 'done) #f]
[(and (pair? v) (eq? (car v) 'result))
(cadr v)]
[else
(error 'handin-connect "commit probably unsucccesful: ~e" v)]))])
(close-input-port r)
(close-output-port w)
result-msg)))
(define (submit-addition h username full-name id passwd)

93
collects/handin-client/tool.ss
View File

@ -34,11 +34,15 @@
(define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f)))
(define web-address (#%info-lookup 'web-address (lambda () #f)))
(preferences:set-default 'submit:username "" string?)
(define preference-key (string->symbol
(format "submit:username:~a"
this-collection)))
(preferences:set-default preference-key "" string?)
(define (remembered-user)
(preferences:get 'submit:username))
(preferences:get preference-key))
(define (remember-user user)
(preferences:set 'submit:username user))
(preferences:set preference-key user))
(define (connect)
(handin-connect server
@ -97,26 +101,32 @@
"Handin failed."
exn))])
(remember-user (send username get-value))
(submit-assignment
connection
(send username get-value)
(send passwd get-value)
(send assignment
get-string
(send assignment get-selection))
content
(lambda ()
(semaphore-wait commit-lock)
(send status set-label "Comitting...")
(set! committing? #t)
(semaphore-post commit-lock)))
(queue-callback
(lambda ()
(when abort-commit-dialog
(send abort-commit-dialog show #f))
(send status set-label "Handin successful.")
(set! committing? #f)
(done-interface))))))))]
(let ([result-msg
(submit-assignment
connection
(send username get-value)
(send passwd get-value)
(send assignment
get-string
(send assignment get-selection))
content
(lambda ()
(semaphore-wait commit-lock)
(send status set-label "Comitting...")
(set! committing? #t)
(semaphore-post commit-lock)))])
(queue-callback
(lambda ()
(when abort-commit-dialog
(send abort-commit-dialog show #f))
(send status set-label "Handin successful.")
(set! committing? #f)
(done-interface)
(when result-msg
(message-box "Handin Result"
result-msg
this
'(ok)))))))))))]
[style '(border)]))
(define ok-can-enable? #f)
@ -129,17 +139,19 @@
[label "Cancel"]
[parent button-panel]
[callback (lambda (b e)
(let ([go? (begin
(semaphore-wait commit-lock)
(if committing?
(begin
(semaphore-post commit-lock)
(send abort-commit-dialog show #t)
continue-abort?)
#t))])
(when go?
(custodian-shutdown-all comm-cust)
(show #f))))]))
(do-cancel-button))]))
(define (do-cancel-button)
(let ([go? (begin
(semaphore-wait commit-lock)
(if committing?
(begin
(semaphore-post commit-lock)
(send abort-commit-dialog show #t)
continue-abort?)
#t))])
(when go?
(custodian-shutdown-all comm-cust)
(show #f))))
(define continue-abort? #f)
(define abort-commit-dialog
@ -182,6 +194,7 @@
(format "~e" exn))]
[retry? (regexp-match #rx"bad username or password for" msg)])
(custodian-shutdown-all comm-cust)
(set! committing? #f)
(disable-interface)
(send status set-label tag)
(when (is-shown?)
@ -225,7 +238,7 @@
(define/augment (on-close)
(inner (void) on-close)
(custodian-shutdown-all comm-cust))
(do-cancel-button))
(send ok enable #f)
(send assignment enable #f)
@ -449,13 +462,15 @@
[mbm2 (and (send bm get-loaded-mask)
(make-object bitmap% (quotient w 2) (quotient h 2)))]
[mdc (make-object bitmap-dc% bm2)])
(send mdc set-scale 0.5 0.5)
(send mdc draw-bitmap bm 0 0)
(send mdc draw-bitmap-section-smooth bm
0 0 (quotient w 2) (quotient h 2)
0 0 w h)
(send mdc set-bitmap #f)
(when mbm2
(send mdc set-bitmap mbm2)
(send mdc set-scale 0.5 0.5)
(send mdc draw-bitmap (send bm get-loaded-mask) 0 0)
(send mdc draw-bitmap-section-smooth (send bm get-loaded-mask)
0 0 (quotient w 2) (quotient h 2)
0 0 w h)
(send mdc set-bitmap #f)
(send bm2 set-loaded-mask mbm2))
bm2))

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

@ -234,16 +234,21 @@ sub-directories:
and the first assignment is the default selection.
Within each directory, the student id is used for a sub-directory
name. Within each student sub-directory are "handin.scm" (or some
other name if `default-file-name' is set), "BACKUP-0", "BACKUP-1",
etc., for each student who submits an assignment. (The most recent
handin is in this directory, and "BACKUP-?" directories hold older
submission for the same assignment.) A `checker' procedure can
replace the name "handin.scm" with something else (possibly
sensitive to the content of the submission), and create additional
files; see below for more details.
name. Within each student sub-directory are directories for handin
attempts and successes. If a directory "ATTEMPT" exists, it
contains the most recent (unsuccessful) handin
attempt. Directories "SUCCESS-n" (where n counts from 0) contain
successful handins; the highest numbered such directory represents
the latest handin.
For submissions from a normal DrScheme frame, a "handin.scm" file
Within an "ATTEMPT" or "SUCCESS-n" directory, a file "handin.scm"
(or some other name if `default-file-name' is set) contains the
actual submission. A `checker' procedure can change this default
file name, it can create additional files in an
"ATTEMPT"/"SUCCESS-n" directory or in the student directory; see
below on "checker.ss" for more details.
For submissions from a normal DrScheme frame, a submission file
contains a copy of the student's definitions and interactions
windows. The file is in a binary format (to support non-text
code), and opening the file directly in DrScheme shows the
@ -251,31 +256,32 @@ sub-directories:
parts, the file can be parsed with `unpack-submission' from
"utils.ss" (see below).
For submissions from a test-suite window, the file is a normal
test-suite file.
* "inactive/" --- sub-directory for inactive assignments, used by the
HTTPS status web server.
* "active/<assignment>/checker.ss" (optional) --- a module that
exports a `checker' function. This function receives two
strings. The first is a username and the second is the user's
submission as a string. (See also `unpack-submission', etc. from
submission as a byte string. (See also `unpack-submission', etc. from
"util.ss", below.) To reject the submission, the `checker'
function can raise an exception; the exception message will be
relayed back to the student. The `checker' function is called when
the current directory is active/<assignment>/<user>, and it can
create additional files in this directory -- such files will get
moved when a backup is done. If you want to hide some of these
files from the web interface, but them in a subdirectory -- it
will be properly backed up, and directories are all hidden from
the web interface.
relayed back to the student.
The checker should return a string, such as "handin.scm", to use in
naming the submission. For submissions that require both programs
and test suites, the checker might use `is-test-suite-submission?'
and return "tests" if the string is a test-suite submission or
"program" if it is not.
The `checker' function is called with the current directory as
"active/<assignment>/<user>/ATTEMPT", and the submission is saved
in the file "handin". The checker function can change "handin",
and it can create additional files in this directory or the parent
directory. (Extra files in the current directory will be preserved
as it is later renamed to "SUCCESS-0", etc.) To hide generated
files from the HTTPS status web server interface, put the files in
a subdirectory, which is preserved but hidden from the status
interface.
The checker should return either a string or a list of two
strings. A single string result, such as "handin.scm", is used to
rename the "handin" submission file. In a list result, the first
string names the submission, and the second string is a
successful-handin message to report back to the student.
* "log.ss" (created if not present, appended otherwise) --- records
connections and actions, where each entry is of the form
@ -297,9 +303,10 @@ sub-directories:
* "[in]active/<assignment>/solution/<file>" --- the solution to the
assignment, made available by the status server to any user who
logs in. There must be only one file in "<assignment>/solution/";
if there are multiple files, only one named "<assignment>sol.scm"
is made available as the solution.
logs in. Normall, <file> is the only file in the directory
"<assignment>/solution/"; if there are multiple files in the
directory, only one named "<assignment>sol.scm" is made available
as the solution.
The server can be run within either MzScheme or MrEd, but "utils.ss"
requires MrEd (which means that `checker' modules will likely require
@ -351,17 +358,6 @@ The _utils.ss_ module provides utilities helpful in implementing
> (unpack-submission bytes) - returns two text% objects corresponding
to the submitted definitions and interactions windows.
> (unpack-test-suite-submission bytes) - returns a pasteboard%
object corresponding to the submitted test-suite window. The
pasteboard contains a sequence of editor-snip% objects, each each
editor-snip% contains a text% with three embedded editor-snip%s: one
for the test expression, one for the expected result, and one for
the equality predicate.
> (is-test-suite-submission? bytes) - returns #t if `string' can be
read as an old-style test suite, #f otherwise.
> (make-evaluator language teachpack-paths program-port) - returns a
function of one argument for evaluating expressions in the
designated teaching language, one of 'beginner, 'beginner-abbr,

93
collects/handin-server/handin-server.ss
View File

@ -62,43 +62,17 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define backup-prefix "BACKUP-")
(define backup-dir-re (regexp (format "^~a[0-9]+$" backup-prefix)))
(define (backup n) (format "~a~a" backup-prefix n))
(define (files+backups)
(let* ([files (map path->string (directory-list))]
[backups (filter (lambda (f)
(and (directory-exists? f)
(regexp-match backup-dir-re f)))
files)])
(values (remove* backups files) backups)))
(define (do-backups)
(let-values ([(files backups) (files+backups)])
(define (make-backup-available n)
(when (member (backup n) backups)
(if (< n MAX-UPLOAD-KEEP)
(begin
(make-backup-available (add1 n))
(rename-file-or-directory (backup n) (backup (add1 n))))
(delete-directory/files (backup n)))))
(unless (null? files)
(LOG "backing up ~a" files)
(make-backup-available 0)
(make-directory (backup 0))
(for-each (lambda (file)
(rename-file-or-directory file (build-path (backup 0) file)))
files))))
(define (undo-backup)
;; It is ok to just move BACKUP-0 to the real directory, the above will
;; just find it available on later backups.
(let-values ([(files backups) (files+backups)])
(LOG "undoing backup")
(for-each delete-directory/files files)
(when (member (backup 0) backups)
(for-each (lambda (file)
(rename-file-or-directory (build-path (backup 0) file) file))
(directory-list (backup 0)))
(delete-directory (backup 0)))))
(define ATTEMPT-DIR "ATTEMPT")
(define (success-dir n)
(format "SUCCESS-~a" n))
(define (make-success-dir-available n)
(let ([name (success-dir n)])
(when (directory-exists? name)
(if (< n MAX-UPLOAD-KEEP)
(begin
(make-success-dir-available (add1 n))
(rename-file-or-directory name (success-dir (add1 n))))
(delete-directory/files name)))))
(define (save-submission s part)
(with-output-to-file part
@ -129,25 +103,38 @@
"error uploading (got ~e, expected ~s bytes)"
(if (bytes? s) (bytes-length s) s)
len))
(do-backups)
;; Shift successful-attempt directories so that there's
;; no SUCCESS-0:
(make-success-dir-available 0)
;; Clear out old ATTEMPT, if any, and make a new one:
(when (directory-exists? ATTEMPT-DIR)
(delete-directory/files ATTEMPT-DIR))
(make-directory ATTEMPT-DIR)
(save-submission s (build-path ATTEMPT-DIR "handin"))
(LOG "checking ~a for ~a" assignment user)
(with-handlers ([void (lambda (e) (undo-backup) (raise e))])
(let ([part
(let ([checker (build-path 'up "checker.ss")])
(if (file-exists? checker)
((dynamic-require `(file ,(path->complete-path checker)) 'checker)
user s)
(let ([part
;; Result is either a string or list of strings:
(let ([checker (build-path 'up "checker.ss")])
(if (file-exists? checker)
(let ([checker (path->complete-path checker)])
(parameterize ([current-directory ATTEMPT-DIR])
((dynamic-require checker 'checker)
user s)))
DEFAULT-FILE-NAME))])
(fprintf w "confirm\n")
(fprintf w "confirm\n")
(flush-output w)
(let ([v (read (make-limited-input-port r 50))])
(if (eq? v 'check)
(begin
(LOG "saving ~a for ~a" assignment user)
(save-submission s part)
(fprintf w "done\n")
(flush-output w))
(error 'handin "upload not confirmed: ~s" v))))))))))
(let ([v (read (make-limited-input-port r 50))])
(if (eq? v 'check)
(begin
(LOG "saving ~a for ~a" assignment user)
(parameterize ([current-directory ATTEMPT-DIR])
(rename-file-or-directory "handin" (if (pair? part) (car part) part)))
(rename-file-or-directory ATTEMPT-DIR (success-dir 0))
(if (pair? part)
(write (list 'result (cadr part)) w)
(fprintf w "done\n"))
(flush-output w))
(error 'handin "upload not confirmed: ~s" v)))))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

52
collects/handin-server/status-web-root/servlets/status.ss
View File

@ -65,13 +65,20 @@
`(a ((href ,(make-k k tag)))
,label))
(define (find-latest dir)
(let ([zero (build-path dir "SUCCESS-0")])
(if (directory-exists? zero)
zero
(build-path dir "SUCCESS-1"))))
(define (handin-link k user hi)
(let* ([dir (build-path handin-dir
(if (directory-exists? (build-path handin-dir "active" hi))
"active"
"inactive")
hi
user)]
(let* ([dir (find-latest
(build-path handin-dir
(if (directory-exists? (build-path handin-dir "active" hi))
"active"
"inactive")
hi
user))]
[l (with-handlers ([exn:fail? (lambda (x) null)])
(parameterize ([current-directory dir])
(filter (lambda (f)
@ -191,23 +198,28 @@
(let ([who (get-status status 'user (lambda () "???"))])
(let-values ([(base name dir?) (split-path tag)])
;; Any file name is ok...
(unless (path? name) (error "bad1"))
(unless (path? name) (error "bad"))
(let-values ([(base name dir?) (split-path base)])
;; Directory must be user or "solution"
(unless (or (string=? (path->string name) who)
(string=? (path->string name) "solution"))
(error "bad2"))
;; Any dir name is ok...
;; Directory must be SUCCESS-0 or SUCCESS-1
(unless (or (string=? (path->string name) "SUCCESS-0")
(string=? (path->string name) "SUCCESS-1"))
(error "bad"))
(let-values ([(base name dir?) (split-path base)])
(unless (path? name) (error "bad3"))
;; Base must be active or inactive
;; Directory must be user or "solution"
(unless (or (string=? (path->string name) who)
(string=? (path->string name) "solution"))
(error "bad"))
;; Any dir name is ok...
(let-values ([(base name dir?) (split-path base)])
(unless (or (string=? (path->string name) "active")
(string=? (path->string name) "inactive"))
(error "bad4"))
;; No more to path
(unless (equal? (build-path base 'same) (build-path handin-dir 'same))
(error "bad5")))))))
(unless (path? name) (error "bad"))
;; Base must be active or inactive
(let-values ([(base name dir?) (split-path base)])
(unless (or (string=? (path->string name) "active")
(string=? (path->string name) "inactive"))
(error "bad"))
;; No more to path
(unless (equal? (build-path base 'same) (build-path handin-dir 'same))
(error "bad"))))))))
;; Return the downloaded file
(let ([data (with-input-from-file tag
(lambda ()