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

Lots of changes to the handin client and server, mostly being able to deal with

Browse Source 
group submission.

svn: r809
This commit is contained in:
Eli Barzilay 2005-09-09 02:36:44 +00:00
parent bcf8da09fe
commit 5622f9466a
8 changed files with 425 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -68,10 +68,10 @@
result-msg)))
(define (submit-addition h username full-name id passwd)
(define (submit-addition h username full-name id email passwd)
(let ([r (handin-r h)]
[w (handin-w h)])
(fprintf w "~s create ~s ~s ~s~n" username full-name id passwd)
(fprintf w "~s create ~s ~s ~s ~s~n" username full-name id email passwd)
(let ([v (read r)])
(unless (eq? v 'ok)
(error 'handin-connect "update error: ~a" v)))

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

@ -53,7 +53,7 @@
(define handin-frame%
(class dialog%
(inherit show is-shown?)
(inherit show is-shown? center)
(super-new [label "Handin"])
(init-field content)
@ -138,8 +138,7 @@
(define cancel (new button%
[label "Cancel"]
[parent button-panel]
[callback (lambda (b e)
(do-cancel-button))]))
[callback (lambda (b e) (do-cancel-button))]))
(define (do-cancel-button)
(let ([go? (begin
(semaphore-wait commit-lock)
@ -245,6 +244,7 @@
(init-comm)
(send passwd focus)
(center)
(show #t)))
(define (manage-handin-account)
@ -322,14 +322,16 @@
(and (non-empty? new-username)
(non-empty? full-name)
(non-empty? student-id)
(non-empty? email)
(non-empty? add-passwd))))
(define new-user-box (new vertical-panel%
[parent single]
[alignment '(center center)]))
(define new-username (mk-txt "Username:" new-user-box activate-new))
(send new-username set-value (remembered-user))
(define full-name (mk-txt "Full Name:" new-user-box activate-new))
(define full-name (mk-txt "Full Name:" new-user-box activate-new))
(define student-id (mk-txt "ID:" new-user-box activate-new))
(define email (mk-txt "Email:" new-user-box activate-new))
(define add-passwd (mk-passwd "Password:" new-user-box activate-new))
(define new-button (new button%
[label "Add User"]
@ -416,10 +418,11 @@
"The \"New\" and \"New again\" passwords are not the same.")
(k (void))))
(when new?
(check-length username 50 "Username" k)
(check-length full-name 100 "Full Name" k)
(check-length student-id 100 "ID" k)
(check-length add-passwd 50 "Password" k))
(check-length username 50 "Username" k)
(check-length full-name 100 "Full Name" k)
(check-length student-id 100 "ID" k)
(check-length email 100 "Email" k)
(check-length add-passwd 50 "Password" k))
(send tabs enable #f)
(parameterize ([current-custodian comm-cust])
(thread
@ -432,19 +435,15 @@
(remember-user (send username get-value))
(send status set-label "Making secure connection...")
(let-values ([(h l) (connect)])
(define (run proc . fields)
(apply proc h (map (lambda (f) (send f get-value))
fields)))
(send status set-label "Updating server...")
(if new?
(submit-addition
h
(send username get-value)
(send full-name get-value)
(send student-id get-value)
(send add-passwd get-value))
(submit-password-change
h
(send username get-value)
(send old-passwd get-value)
(send new-passwd get-value))))
(run submit-addition
username full-name student-id email add-passwd)
(run submit-password-change
username old-passwd new-passwd)))
(send status set-label "Success.")
(send cancel set-label "Close")))))))
@ -519,7 +518,7 @@
(define/override (file-menu:between-open-and-revert file-menu)
(new menu-item%
(label (format "Manage ~a..." handin-name))
(label (format "Manage ~a Account..." handin-name))
(parent file-menu)
(callback (lambda (m e) (manage-handin-account))))
(super file-menu:between-open-and-revert file-menu))

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

@ -24,9 +24,7 @@ account (i.e., changing the password, or creating a new account if the
instructor configures the server to allow new accounts).
On the instructor's side, the handin server can be configured to check
the student's submission before accepting it. Other configuration of
the server includes setting the list of currently active assignments
(i.e., those for which handins are accepted).
the student's submission before accepting it.
The handin process uses SSL, so it is effectively as secure as the
server and each user's password.
@ -197,13 +195,28 @@ sub-directories:
oldest is in "BACKUP-0/handin.scm", next oldest is
"BACKUP-1/handin.scm", etc.; the default is 9
'id-regexp : a regular expression used to validate a "free form"
user id (possibly a student id) for a created account; the
'user-regexp : a regular expression that is used to validate
usernames, young students often choose exotic usernames that
are impossible to remember, and forget capitalization; the
default is fairly strict: #rx"^[a-z][a-z0-9]+$"
'username-case-sensitive? : a boolean flag, when #f, usernames
are normalized to lower case for all messages; defaults to #f
'id-regexp : a regular expression that is used to validate a
"free form" user id (possibly a student id) for a created
account; the
default is #rx"^.*$"
'id-desc : a plain-words description of the acceptable format
for a "free form" id; the default is "anything"
'email-regexp : a regular expression that is used to validate
emails, the #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
default can be changed to "" if you don't care about emails,
or can be further restricted, for example requiring a
"@cs.foo.edu" suffix
'allow-new-users : a boolean indicating whether to allow
new-user requests from a client tool; the default is #f
@ -211,13 +224,22 @@ sub-directories:
allows login as any user; the default is #f, which disables
the password
'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" to the
directory you're running the handin server server from, and
add this configuration entry with the name of your new copy
(relative to the handin server directory).
* "users.ss" (created if not present if a user is added) --- keeps
the list of user accounts, along with the associated password
(actually the MD5 hash of the password), full name, and free-form
id (perhaps a student id at a university) of the account. The file
format is
((<username-sym> (<pw-md5-str> <full-name-str> <id-str>)) ...)
((<username-sym> (<pw-md5-str> <id-str> <full-name-str> <email-str>))
...)
If the 'allow-new-users configuration allows new users, the
"users.ss" file can be updated by the server with new users. It
@ -226,12 +248,12 @@ sub-directories:
The username "solution" is special. It is used by the HTTPS status
server.
* "active/" --- sub-directory for active assignments. A list of active
assignments is sent to a client tool when a student clicks
"Handin". The student then selects from the list. The list of
active assignments is built once by the server when it starts.
The assignments are ordered in the student's menu using `string<?',
and the first assignment is the default selection.
* "active/" --- sub-directory for active assignments. A list of
active assignments is sent to a client tool when a student clicks
"Handin", based on the contents of this directory. The student
then selects from the list. The assignments are ordered in the
student's menu using `string<?', 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 directories for handin
@ -261,21 +283,29 @@ sub-directories:
* "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 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.
strings. The first is a username list and the second is the
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.
To submit an assignment as a group, students use "user1+user2"
etc. The checker function will receive a list of usernames in
this case -- this list is always sorted, so it can check that the
list of students are in a list of authorized teams. The same
syntax ("user1+user2") is used for the directory for shared
submissions; and the usernames are always sorted so the directory
name is deterinistic.
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.
"active/<assignment>/<user/s>/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
@ -297,13 +327,15 @@ sub-directories:
most recent submission for <assignment> by <user> where <filename>
was returned by the checker (or the value of the
`default-file-name' configuration option if there's no checker).
If the submission is from multiple users, then "<user>" is
actually "<user1>+<user2>" etc.
* "[in]active/<assignment>/<user>/grade" (optional) --- <user>'s grade
for <assignment>, to be reported by the HTTPS status web server.
* "[in]active/<assignment>/solution/<file>" --- the solution to the
assignment, made available by the status server to any user who
logs in. Normall, <file> is the only file in the directory
logs in. Normally, <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.
@ -360,15 +392,31 @@ The _utils.ss_ module provides utilities helpful in implementing
> (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,
'intermediate, 'intermediate-lambda, or 'advanced. The
`teachpack-paths' list contains paths to teachpacks to load in the
evaluator. The `program-port' is an input port that produces the
content of the definitions window; use `(open-input-string "")'
for an empty definitions window.
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:
* a symbol indicating a built-in language (currently, only
'mzscheme), or a teaching language -- one of 'beginner,
'beginner-abbr, 'intermediate, 'intermediate-lambda, or 'advanced.
* a list that begins with a 'lib symbol stands for the language
defined by this (quoted) module specification.
* a list that begins with a 'begin symbol means that the code will
not be evaluated in a module context at all, it will simply be
evaluated in a new namespace.
The `teachpack-paths' list specifies additional code to load, can be
one of:
* paths to teachpacks to load into the module.
* a list that begins with a 'begin symbol is arbitrary code that is
prefixed into the submitted program.
The actual evaluation of expressions happens in a newly created
eventspace and namespace.
eventspace and namespace, and under the supervision of a strict
security guard that reading files only from PLT collections, and no
other operations.
> (make-evaluator/submission language teachpack-paths bytes) - like
`make-evaluator', but the definitions content is supplied as a
@ -432,6 +480,11 @@ The _utils.ss_ module provides utilities helpful in implementing
used when per-session memory limits are supported (i.e., under
MrEd3m or MzScheme3m with memory accounting).
> (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.

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

@ -6,6 +6,7 @@
(lib "file.ss")
(lib "date.ss")
(lib "list.ss")
(lib "string.ss")
"md5.ss"
"lock.ss"
"web-status-server.ss"
@ -15,6 +16,10 @@
(define current-session (make-parameter 0))
(define (ffprintf port str . args)
(apply fprintf port str args)
(flush-output port))
(define (LOG str . args)
;; Assemble log into into a single string, to make
;; interleaved log lines unlikely:
@ -28,25 +33,22 @@
(flush-output log-port)))
(define (get-config which default)
(get-preference which
(lambda () default)
#f
"config.ss"))
(get-preference which (lambda () default) #f "config.ss"))
(define PORT-NUMBER (get-config 'port-number 7979))
(define PORT-NUMBER (get-config 'port-number 7979))
(define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
(define SESSION-TIMEOUT (get-config 'session-timeout 300))
(define SESSION-TIMEOUT (get-config 'session-timeout 300))
(define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000))
(define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
(define MAX-UPLOAD (get-config 'max-upload 500000))
(define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
(define ID-REGEXP (get-config 'id-regexp #rx"^.*$"))
(define ID-DESC (get-config 'id-desc "anything"))
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
(define MASTER-PASSWD (get-config 'master-password #f))
(define (check-id s)
(regexp-match ID-REGEXP s))
(define MAX-UPLOAD (get-config 'max-upload 500000))
(define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
(define USER-REGEXP (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
(define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f))
(define ID-REGEXP (get-config 'id-regexp #rx"^.*$"))
(define ID-DESC (get-config 'id-desc "anything"))
(define EMAIL-REGEXP (get-config 'email-regexp #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"))
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
(define MASTER-PASSWD (get-config 'master-password #f))
(define orig-custodian (current-custodian))
@ -80,64 +82,75 @@
(with-output-to-file part
(lambda () (display s))))
(define (accept-specific-submission user assignment r r-safe w)
(define (accept-specific-submission users assignment r r-safe w)
;; Note: users are always sorted
(define dirname
(apply string-append (car users)
(map (lambda (u) (string-append "+" u)) (cdr users))))
(define len (read r-safe))
(unless (and (number? len) (integer? len) (positive? len))
(error 'handin "bad length: ~s" len))
(unless (len . < . MAX-UPLOAD)
(error 'handin
"max handin file size is ~s bytes, file to handin is too big (~s bytes)"
MAX-UPLOAD len))
(parameterize ([current-directory (build-path "active" assignment)])
(unless (directory-exists? user)
(make-directory user))
(wait-for-lock user)
(parameterize ([current-directory user])
(let ([len (read r-safe)])
(unless (and (number? len)
(integer? len)
(positive? len))
(error 'handin "bad length: ~s" len))
(unless (len . < . MAX-UPLOAD)
(error 'handin
"max handin file size is ~s bytes, file to handin is too big (~s bytes)"
MAX-UPLOAD len))
(fprintf w "go\n")
(flush-output w)
(unless (regexp-match #rx"[$]" r-safe)
(error 'handin
"did not find start-of-content marker"))
(let ([s (read-bytes len r)])
(unless (and (bytes? s) (= (bytes-length s) len))
(error 'handin
"error uploading (got ~e, expected ~s bytes)"
(if (bytes? s) (bytes-length s) s)
len))
;; 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)
(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")
(flush-output w)
(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)))))))))
(wait-for-lock dirname)
(when (and (pair? users) (pair? (cdr users)))
;; two or more users -- lock each one
(for-each wait-for-lock users))
(ffprintf w "go\n")
(unless (regexp-match #rx"[$]" r-safe)
(error 'handin "did not find start-of-content marker"))
(let ([s (read-bytes len r)])
(unless (and (bytes? s) (= (bytes-length s) len))
(error 'handin "error uploading (got ~e, expected ~s bytes)"
(if (bytes? s) (bytes-length s) s) len))
;; we have a submission, need to create a directory if needed, make
;; sure that no users submitted work with someone else
(unless (directory-exists? dirname)
(for-each
(lambda (dir)
(for-each
(lambda (d)
(when (member d users)
(error 'handin
"bad submission: ~a has an existing submission (~a)"
d dir)))
(regexp-split #rx"[+]" (path->string dir))))
(directory-list))
(make-directory dirname))
(parameterize ([current-directory dirname])
;; 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 users)
(let ([part
;; Result is either a string or list of strings:
(let ([checker (build-path 'up "checker.ss")])
(if (file-exists? checker)
(parameterize ([current-directory ATTEMPT-DIR])
((dynamic-require (path->complete-path checker) 'checker)
users s))
DEFAULT-FILE-NAME))])
(ffprintf w "confirm\n")
(let ([v (read (make-limited-input-port r 50))])
(if (eq? v 'check)
(begin
(LOG "saving ~a for ~a" assignment users)
(parameterize ([current-directory ATTEMPT-DIR])
(rename-file-or-directory "handin" (if (pair? part) (car part) part)))
;; Shift successful-attempt directories so that there's
;; no SUCCESS-0:
(make-success-dir-available 0)
(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))))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -153,18 +166,23 @@
(lambda (f)
(error
'handin
"user database busy; please try again, and alert the adminstrator is problems persist"))
"user database busy; please try again, and alert the adminstrator if problems persist"))
"users.ss"))
orig-custodian))
(define (add-new-user username r-safe w)
(thread (lambda () (sleep 5) (close-input-port r-safe)))
(let ([full-name (read r-safe)]
[id (read r-safe)]
[passwd (read r-safe)])
[id (read r-safe)]
[email (read r-safe)]
[passwd (read r-safe)])
(unless (and (string? full-name)
(string? id)
(string? email)
(string? passwd))
(error 'handin "bad user-addition request"))
(unless (regexp-match USER-REGEXP username)
(error 'handin "bad user name: \"~a\"" username))
;; Since we're going to use the username in paths:
(when (regexp-match #rx"[/\\:]" username)
(error 'handin "username must not contain a slash, backslash, or colon"))
@ -173,10 +191,13 @@
(error 'handin "username must not be a Windows special file name"))
(when (string=? "solution" username)
(error 'handin "the username \"solution\" is reserved"))
(unless (check-id id)
(unless (regexp-match ID-REGEXP id)
(error 'handin "id has wrong format: ~a; need ~a for id" id ID-DESC))
(unless (regexp-match EMAIL-REGEXP email)
(error 'handin "email has wrong format: ~a" email))
(LOG "create user: ~a" username)
(put-user (string->symbol username)
(list (md5 passwd) id full-name))
(list (md5 passwd) id full-name email))
(fprintf w "ok~n")))
(define (change-user-passwd username r-safe w old-user-data)
@ -192,43 +213,57 @@
(define (accept-submission-or-update active-assignments r r-safe w)
(fprintf w "~s~n" active-assignments)
;; Get username and password:
(let ([username (read r-safe)]
[passwd (read r-safe)])
(let ([user-data
(and (string? username)
(get-preference (string->symbol username)
(lambda () #f)
#f
"users.ss"))])
(cond
[(eq? passwd 'create)
(when user-data
(error 'handin "username already exists: ~a" username))
(unless ALLOW-NEW-USERS?
(error 'handin "new users not allowed: ~a" username))
(LOG "create user: ~a" username)
(add-new-user username r-safe w)]
[(and user-data
(string? passwd)
(let ([pw (md5 passwd)])
(or (equal? pw (car user-data))
(equal? pw MASTER-PASSWD))))
(LOG "login: ~a" username)
(let ([assignment (read r-safe)])
(LOG "assignment for ~a: ~a" username assignment)
(if (eq? assignment 'change)
(change-user-passwd username r-safe w user-data)
(if (member assignment active-assignments)
(begin
(fprintf w "ok\n")
(accept-specific-submission username assignment r r-safe w))
(error 'handin "not an active assignment: ~a" assignment))))]
[else
(LOG "failed login: ~a" username)
(error 'handin "bad username or password for ~a" username)]))))
;; Get usernames and password:
(let* ([user-string
(let ([s (read r-safe)])
(and (string? s)
(if USERNAME-CASE-SENSITIVE?
s
(let ([s (string-copy s)]) (string-lowercase! s) s))))]
[usernames
;; User name lists must always be sorted
(if user-string
(quicksort (regexp-split #rx" *[+] *" user-string) string<?)
'())]
[user-datas (map (lambda (u)
(get-preference (string->symbol u)
(lambda () #f) #f "users.ss"))
usernames)]
[passwd (read r-safe)])
(cond
[(eq? passwd 'create)
(unless ALLOW-NEW-USERS?
(error 'handin "new users not allowed: ~a" user-string))
(unless (= 1 (length usernames))
(error 'handin "username must not contain a \"+\": ~a" user-string))
;; we now know that there is a single username, and (car usernames) is
;; the same at user-string
(when (car user-datas)
(error 'handin "username already exists: `~a'" user-string))
(add-new-user user-string r-safe w)]
[(and (pair? user-datas)
(not (memq #f user-datas))
(string? passwd)
(let ([pw (md5 passwd)])
(ormap (lambda (p) (equal? p pw))
(cons MASTER-PASSWD (map car user-datas)))))
(LOG "login: ~a" usernames)
(let ([assignment (read r-safe)])
(LOG "assignment for ~a: ~a" usernames assignment)
(if (eq? assignment 'change)
(if (= 1 (length usernames))
(change-user-passwd (car usernames) r-safe w (car user-datas))
(error 'handin "cannot change a password on a joint login"))
(if (member assignment active-assignments)
(begin
(fprintf w "ok\n")
(accept-specific-submission usernames assignment r r-safe w))
(error 'handin "not an active assignment: ~a" assignment))))]
[else
(LOG "failed login: ~a" user-string)
(error 'handin "bad username or password for ~a" user-string)])))
(define assignment-list
(define (assignment-list)
(quicksort (map path->string (directory-list "active")) string<?))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -295,7 +330,7 @@
(LOG "server started ------------------------------")
(define stop-status (serve-status HTTPS-PORT-NUMBER))
(define stop-status (serve-status HTTPS-PORT-NUMBER get-config))
(define session-count 0)
@ -316,8 +351,7 @@
w
(lambda (kill-watcher)
(let ([r-safe (make-limited-input-port r 1024)])
(fprintf w "handin\n")
(flush-output w)
(ffprintf w "handin\n")
;; Check protocol:
(with-handlers ([exn:fail?
(lambda (exn)
@ -326,17 +360,14 @@
(format "~e" exn))])
(kill-watcher)
(LOG "ERROR: ~a" msg)
(fprintf w "~s\n" msg)
(flush-output w)
(ffprintf w "~s\n" msg)
;; see note on close-output-port below
(close-output-port w)))])
(let ([protocol (read r-safe)])
(if (eq? protocol 'original)
(begin
(fprintf w "original\n")
(flush-output w))
(ffprintf w "original\n")
(error 'handin "unknown protocol: ~s" protocol)))
(accept-submission-or-update assignment-list r r-safe w)
(accept-submission-or-update (assignment-list) r r-safe w)
(LOG "normal exit")
(kill-watcher)
;; This close-output-port should not be necessary, and it's

99
collects/handin-server/lock.ss
View File

@ -5,56 +5,61 @@
(provide wait-for-lock)
;; wait-for-lock : string -> void
;; Gets a lock on `user' for the calling thread; the lock
;; lasts until the calling thread terminates.
(define (wait-for-lock user)
;; Gets a lock on `user' for the calling thread; the lock lasts until the
;; calling thread terminates. If the lock was actually acquired, then on
;; release the cleanup-thunk will be executed (unless it is #f), even if it
;; was released when the acquiring thread crashed.
;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception,
;; since this will kill the lock thread which will lock down everything
(define (wait-for-lock user . cleanup-thunk)
(let ([s (make-semaphore)])
(channel-put req-ch (make-req
(thread-dead-evt (current-thread))
user
s))
(channel-put req-ch
(make-req (thread-dead-evt (current-thread)) user s
(and (pair? cleanup-thunk) (car cleanup-thunk))))
(semaphore-wait s)))
(define req-ch (make-channel))
(define-struct req (thread-dead-evt
user
sema))
(define-struct req (thread-dead-evt user sema cleanup-thunk))
(thread (lambda ()
(let loop ([locks null]
[reqs null])
(let-values ([(locks reqs)
;; Try to satisfy lock requests:
(let loop ([reqs (reverse reqs)][locks locks][new-reqs null])
(cond
[(null? reqs) (values locks new-reqs)]
[(assoc (req-user (car reqs)) locks)
;; Lock not available:
(loop (cdr reqs) locks (cons (car reqs) new-reqs))]
[else
;; Lock is available, so take it:
(let ([req (car reqs)])
(semaphore-post (req-sema req))
(loop (cdr reqs) (cons (cons (req-user req) req) locks) new-reqs))]))])
(sync
(handle-evt
req-ch
(lambda (req)
(loop locks (cons req reqs))))
;; Release a lock whose thread is gone:
(apply choice-evt
(map (lambda (name+req)
(handle-evt
(req-thread-dead-evt (cdr name+req))
(lambda (v)
(loop (remq name+req locks) reqs))))
locks))
;; Throw away a request whose thread is gone:
(apply choice-evt
(map (lambda (req)
(handle-evt
(req-thread-dead-evt req)
(lambda (v)
(loop locks (remq req reqs)))))
reqs))))))))
(thread
(lambda ()
(let loop ([locks null]
[reqs null])
(let-values ([(locks reqs)
;; Try to satisfy lock requests:
(let loop ([reqs (reverse reqs)]
[locks locks]
[new-reqs null])
(if (null? reqs)
(values locks new-reqs)
(let ([req (car reqs)]
[rest (cdr reqs)])
(if (assoc (req-user req) locks)
;; Lock not available:
(loop rest locks (cons req new-reqs))
;; Lock is available, so take it:
(begin (semaphore-post (req-sema req))
(loop (cdr reqs)
(cons (cons (req-user req) req) locks)
new-reqs))))))])
(sync
(handle-evt req-ch (lambda (req) (loop locks (cons req reqs))))
;; Release a lock whose thread is gone:
(apply choice-evt
(map (lambda (name+req)
(handle-evt
(req-thread-dead-evt (cdr name+req))
(lambda (v)
;; releasing a lock => run cleanup
(cond [(req-cleanup-thunk (cdr name+req))
=> (lambda (t) (t))])
(loop (remq name+req locks) reqs))))
locks))
;; Throw away a request whose thread is gone:
(apply choice-evt
(map (lambda (req)
(handle-evt
(req-thread-dead-evt req)
(lambda (v) (loop locks (remq req reqs)))))
reqs))))))))

2
collects/handin-server/status-web-root/htdocs/index.html
View File

@ -2,5 +2,7 @@
<head><title>Handin Status Web Server</title></head>
<body>
The handin status server is running.
<br>
You can <a href="/servlets/status.ss">check your submissions</a> on this server.
</body>
</html>

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

@ -5,7 +5,8 @@
"run-status.ss"
(prefix pc: (lib "pconvert.ss"))
(lib "pretty.ss")
(lib "list.ss"))
(lib "list.ss")
(lib "string.ss"))
(provide unpack-submission
@ -21,6 +22,7 @@
call-with-evaluator/submission
reraise-exn-as-submission-problem
current-run-status
current-value-printer
check-proc
check-defined
@ -130,6 +132,31 @@
(super-new)))
;; Protection ---------------------------------------
(define ok-path-re
(regexp
(string-append
"^(?:"
(apply string-append
(cdr (apply append (map (lambda (p) (list "|" (regexp-quote p)))
(current-library-collection-paths)))))
")(?:/|$)")))
(define tight-security
(make-security-guard
(current-security-guard)
(lambda (what path modes)
(when (or (memq 'write modes)
(memq 'execute modes)
(memq 'delete modes)
(not (regexp-match ok-path-re (path->string path))))
(error what "file access denied (~a)" path)))
(lambda (what host port mode) (error what "network access denied"))))
(define (safe-eval expr)
(parameterize ([current-security-guard tight-security])
(eval expr)))
;; Execution ----------------------------------------
@ -149,27 +176,55 @@
(lambda ()
;; First read program and evaluate it as a module:
(with-handlers ([void (lambda (exn) (channel-put result-ch (cons 'exn exn)))])
(let ([prog-body
(parameterize ([read-case-sensitive #t]
[read-decimal-as-inexact #f])
(let loop ([l null])
(let ([expr (read-syntax 'program program-port)])
(if (eof-object? expr)
(reverse l)
(loop (cons expr l))))))])
(eval `(module m (lib ,(case language
[(beginner) "htdp-beginner.ss"]
[(beginner-abbr) "htdp-beginner-abbr.ss"]
[(intermediate) "htdp-intermediate.ss"]
[(intermediate-lambda) "htdp-intermediate-lambda.ss"]
[(advanced) "htdp-advanced.ss"])
"lang")
,@(map (lambda (tp)
`(,#'require (file ,tp)))
teachpacks)
,@prog-body))
(eval `(require m))
(current-namespace (module->namespace 'm)))
(let* ([body
(parameterize ([read-case-sensitive #t]
[read-decimal-as-inexact #f])
(let loop ([l null])
(let ([expr (read-syntax 'program program-port)])
(if (eof-object? expr)
(reverse l)
(loop (cons expr l))))))]
[body (append (if (and (pair? teachpacks)
(eq? 'begin (car teachpacks)))
(cdr teachpacks)
(map (lambda (tp)
`(,#'require
,(if (pair? tp)
tp `(file ,tp))))
teachpacks))
body)]
[body
(cond
[(and (symbol? language)
(memq language '(beginner
beginner-abbr
intermediate
intermediate-lambda
advanced)))
`(module m
(lib ,(case language
[(beginner) "htdp-beginner.ss"]
[(beginner-abbr) "htdp-beginner-abbr.ss"]
[(intermediate) "htdp-intermediate.ss"]
[(intermediate-lambda) "htdp-intermediate-lambda.ss"]
[(advanced) "htdp-advanced.ss"])
"lang")
,@body)]
[(or (and (pair? language) (eq? 'lib (car language)))
(symbol? language))
`(module m ,language ,@body)]
[(and (pair? language)
(eq? 'begin (car language)))
`(begin ,language ,@body)]
[else (error 'make-evaluator
"Bad language specification: ~e"
language)])])
(safe-eval body)
(when (and (pair? body) (eq? 'module (car body))
(pair? (cdr body)) (symbol? (cadr body)))
(let ([mod (cadr body)])
(safe-eval `(require ,mod))
(current-namespace (module->namespace mod)))))
(channel-put result-ch 'ok))
;; Now wait for interaction expressions:
(let loop ()
@ -177,7 +232,7 @@
(unless (eof-object? expr)
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(channel-put result-ch (cons 'val (eval expr))))
(channel-put result-ch (cons 'val (safe-eval expr))))
(loop))))
(let loop ()
(channel-put result-ch '(exn . no-more-to-evaluate))
@ -304,7 +359,7 @@
[pc:constructor-style-printing #t])
(pc:print-convert v)))
(define (value-printer v)
(define (default-value-printer v)
(parameterize ([pretty-print-show-inexactness #t]
[pretty-print-.-symbol-without-bars #t]
[pretty-print-exact-as-decimal #t]
@ -313,10 +368,11 @@
(let ([p (open-output-string)])
(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)
(value-printer v))]
((current-value-printer) v))]
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
(eq? lang 'beginner-abbr)))])
(reraise-exn-as-submission-problem
@ -330,4 +386,3 @@
(call-with-evaluator lang teachpacks (open-input-text-editor defs) go)))
)

17
collects/handin-server/web-status-server.ss
View File

@ -7,11 +7,20 @@
(lib "ssl-tcp-unit.ss" "net")
(lib "tcp-sig.ss" "net")
(lib "tcp-unit.ss" "net")
(lib "file.ss"))
(lib "file.ss")
(lib "etc.ss"))
(provide serve-status)
(define (serve-status port-no)
(define (serve-status port-no get-config)
(define WEB-BASE-DIR (get-config 'web-base-dir #f))
(define web-dir
(path->string
(if WEB-BASE-DIR
(build-path (current-directory) WEB-BASE-DIR)
(build-path (this-expression-source-directory) "status-web-root"))))
(define config
`((port ,port-no)
@ -37,10 +46,10 @@
(file-base-connection-timeout 30))
(paths
(configuration-root "conf")
(host-root ,(path->string (build-path (collection-path "handin-server") "status-web-root")))
(host-root ,web-dir)
(log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss")))
(file-root "htdocs")
(servlet-root ,(path->string (build-path (collection-path "handin-server") "status-web-root")))
(servlet-root ,web-dir)
(password-authentication ,(path->string (build-path (current-directory) "web-status-passwords"))))))
(virtual-host-table)))