From 39a44d0849717d1d16025580d0db12bf0828e2ab Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 8 Sep 2005 13:34:52 +0000
Subject: [PATCH] added user-directory lock

svn: r796
---
 collects/handin-server/handin-server.ss |  3 ++
 collects/handin-server/lock.ss          | 60 +++++++++++++++++++++++++
 2 files changed, 63 insertions(+)
 create mode 100644 collects/handin-server/lock.ss

diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss
index 7c616f2f7a..48727e3aa2 100644
--- a/collects/handin-server/handin-server.ss
+++ b/collects/handin-server/handin-server.ss
@@ -7,6 +7,7 @@
 	   (lib "date.ss")
 	   (lib "list.ss")
 	   "md5.ss"
+	   "lock.ss"
 	   "web-status-server.ss"
 	   "run-status.ss")
 
@@ -63,6 +64,7 @@
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
   (define ATTEMPT-DIR "ATTEMPT")
+
   (define (success-dir n) 
     (format "SUCCESS-~a" n))
   (define (make-success-dir-available n)
@@ -82,6 +84,7 @@
     (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)
diff --git a/collects/handin-server/lock.ss b/collects/handin-server/lock.ss
new file mode 100644
index 0000000000..77bfc8b692
--- /dev/null
+++ b/collects/handin-server/lock.ss
@@ -0,0 +1,60 @@
+
+(module lock mzscheme
+  (require (lib "list.ss"))
+
+  (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)
+    (let ([s (make-semaphore)])
+      (channel-put req-ch (make-req 
+			   (thread-dead-evt (current-thread))
+			   user
+			   s))
+      (semaphore-wait s)))
+
+  (define req-ch (make-channel))
+  
+  (define-struct req (thread-dead-evt
+		      user
+		      sema))
+
+  (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))))))))