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

semaphore for cleanup, configurable error messages

Browse Source 
svn: r827
This commit is contained in:
Eli Barzilay 2005-09-10 10:00:52 +00:00
parent 6cb6343634
commit 690c4b2517
2 changed files with 38 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -200,6 +200,11 @@ sub-directories:
are impossible to remember, and forget capitalization; the
default is fairly strict: #rx"^[a-z][a-z0-9]+$"
'user-desc : a plain-words description of the acceptable
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 case-folded for all purposes; defaults to #f
(note that you should not set this to #t on Windows, since
@ -209,8 +214,9 @@ sub-directories:
"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"
'id-desc : a plain-words description of the acceptable id format
(according to id-regexp above), eg, "Foo ID Number"; the
default is #f indicating no description
'email-regexp : a regular expression that is used to validate
emails, the #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
@ -218,6 +224,11 @@ sub-directories:
or can be further restricted, for example requiring a
"@cs.foo.edu" suffix
'email-desc : a plain-words description of the acceptable email
format (according to email-regexp above), eg, "Foo CS email";
#f stands for no description; the default is "a valid email
address"
'allow-new-users : a boolean indicating whether to allow
new-user requests from a client tool; the default is #f

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

@ -43,10 +43,12 @@
(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 USER-DESC (get-config 'user-desc "alphanumeric string"))
(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 ID-DESC (get-config 'id-desc #f))
(define EMAIL-REGEXP (get-config 'email-regexp #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"))
(define EMAIL-DESC (get-config 'email-desc "a valid email address"))
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
(define MASTER-PASSWD (get-config 'master-password #f))
@ -92,17 +94,8 @@
(current-directory dir) #t)
body ...))))]))
(define (cleanup-submission dir)
;; This is called at a lock cleanup, so it is important that it does not
;; throw an exception, or the whole server will be locked down. It is
;; invoked just before the lock is released, so fine to assume that we have
;; 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)))])
(parameterize ([current-directory dir])
;; Find the newest SUCCESS dir -- ignore ATTEMPT, since if it exist it
(define (cleanup-submission-body)
;; Find the newest SUCCESS dir -- ignore ATTEMPT, since if it exist it
;; means that there was a failed submission and the next one will
;; re-create ATTEMPT.
(let* ([dirlist (map path->string (directory-list))]
@ -135,7 +128,20 @@
;; f is newer in dir than in the working directory
(delete-directory/files f)
(copy-directory/files dir/f f)]))
(directory-list dir)))))))
(directory-list dir)))))
(define cleanup-sema (make-semaphore 1))
(define (cleanup-submission dir)
;; This is called at a lock cleanup, so it is important that it does not
;; throw an exception, or the whole server will be locked down. It is
;; invoked just before the lock is released, so fine to assume that we have
;; 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)))])
(parameterize ([current-directory dir])
(call-with-semaphore cleanup-sema cleanup-submission-body))))
(define (cleanup-all-submissions)
(LOG "Cleaning up all submission directories")
@ -280,7 +286,8 @@
(string? passwd))
(error 'handin "bad user-addition request"))
(unless (regexp-match USER-REGEXP username)
(error 'handin "bad username: \"~a\"" username))
(error 'handin "bad username: \"~a\"~a" username
(if USER-DESC (format "; need ~a" USER-DESC) "")))
;; Since we're going to use the username in paths:
(when (regexp-match #rx"[/\\:|\"<>]" username)
(error 'handin "username must not contain one of the following: / \\ : | \" < >"))
@ -294,9 +301,11 @@
(when (string=? "checker.ss" username)
(error 'handin "the username \"checker.ss\" is reserved"))
(unless (regexp-match ID-REGEXP id)
(error 'handin "id has wrong format: ~a; need ~a for id" id ID-DESC))
(error 'handin "id has wrong format: ~a~a" id
(if ID-DESC (format "; need ~a for id" ID-DESC) "")))
(unless (regexp-match EMAIL-REGEXP email)
(error 'handin "email has wrong format: ~a" email))
(error 'handin "email has wrong format: ~a~a" email
(if EMAIL-DESC (format "; need ~a" EMAIL-DESC) "")))
(LOG "create user: ~a" username)
(put-user (string->symbol username)
(list (md5 passwd) id full-name email))