From 94b06deb64c7152aef718cb26ed804266902a6a9 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 6 Jul 2012 21:45:08 -0600
Subject: [PATCH] fix transfer slots blocking and refilling when transfers are
 stopped

---
 Assistant.hs                         |  2 +-
 Assistant/Threads/TransferWatcher.hs | 25 ++++++++++++++-----------
 Assistant/TransferSlots.hs           | 13 +++++++++++--
 3 files changed, 26 insertions(+), 14 deletions(-)

diff --git a/Assistant.hs b/Assistant.hs
index 06484b0862..91ebf2d2e0 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -123,7 +123,7 @@ startDaemon assistant foreground
 				, pushThread st dstatus commitchan pushmap
 				, pushRetryThread st pushmap
 				, mergeThread st
-				, transferWatcherThread st dstatus
+				, transferWatcherThread st dstatus transferslots
 				, transfererThread st dstatus transferqueue transferslots
 				, daemonStatusThread st dstatus
 				, sanityCheckerThread st dstatus transferqueue changechan
diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs
index 4e468a4165..aa8b3f6e68 100644
--- a/Assistant/Threads/TransferWatcher.hs
+++ b/Assistant/Threads/TransferWatcher.hs
@@ -10,6 +10,7 @@ module Assistant.Threads.TransferWatcher where
 import Common.Annex
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
+import Assistant.TransferSlots
 import Logs.Transfer
 import Utility.DirWatcher
 import Utility.Types.DirWatcher
@@ -19,12 +20,12 @@ import Data.Map as M
 
 {- This thread watches for changes to the gitAnnexTransferDir,
  - and updates the DaemonStatus's map of ongoing transfers. -}
-transferWatcherThread :: ThreadState -> DaemonStatusHandle -> IO ()
-transferWatcherThread st dstatus = do
+transferWatcherThread :: ThreadState -> DaemonStatusHandle -> TransferSlots -> IO ()
+transferWatcherThread st dstatus transferslots = do
 	g <- runThreadState st $ fromRepo id
 	let dir = gitAnnexTransferDir g
 	createDirectoryIfMissing True dir
-	let hook a = Just $ runHandler st dstatus a
+	let hook a = Just $ runHandler st dstatus transferslots a
 	let hooks = mkWatchHooks
 		{ addHook = hook onAdd
 		, delHook = hook onDel
@@ -32,25 +33,25 @@ transferWatcherThread st dstatus = do
 		}
 	void $ watchDir dir (const False) hooks id
 
-type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus -> IO ()
+type Handler = ThreadState -> DaemonStatusHandle -> TransferSlots -> FilePath -> Maybe FileStatus -> IO ()
 
 {- Runs an action handler.
  -
  - Exceptions are ignored, otherwise a whole thread could be crashed.
  -}
-runHandler :: ThreadState -> DaemonStatusHandle -> Handler -> FilePath -> Maybe FileStatus -> IO ()
-runHandler st dstatus handler file filestatus = void $ do
+runHandler :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Handler -> FilePath -> Maybe FileStatus -> IO ()
+runHandler st dstatus transferslots handler file filestatus = void $ do
         either print (const noop) =<< tryIO go
         where
-                go = handler st dstatus file filestatus
+                go = handler st dstatus transferslots file filestatus
 
 {- Called when there's an error with inotify. -}
 onErr :: Handler
-onErr _ _ msg _ = error msg
+onErr _ _ _ msg _ = error msg
 
 {- Called when a new transfer information file is written. -}
 onAdd :: Handler
-onAdd st dstatus file _ = case parseTransferFile file of
+onAdd st dstatus _ file _ = case parseTransferFile file of
 	Nothing -> noop
 	Just t -> runThreadState st $ go t =<< checkTransfer t
 	where
@@ -64,7 +65,7 @@ onAdd st dstatus file _ = case parseTransferFile file of
  - to avoid zombies.
  -}
 onDel :: Handler
-onDel st dstatus file _ = case parseTransferFile file of
+onDel st dstatus transferslots file _ = case parseTransferFile file of
 	Nothing -> noop
 	Just t -> maybe noop waitchild
 		=<< runThreadState st (removeTransfer dstatus t)
@@ -73,6 +74,8 @@ onDel st dstatus file _ = case parseTransferFile file of
 			| shouldWait info = case transferPid info of
 				Nothing -> noop
 				Just pid -> do
-					void $ getProcessStatus True False pid
+					void $ tryIO $ 
+						getProcessStatus True False pid
 					runThreadState st invalidateCache
+					transferComplete transferslots
 			| otherwise = noop	
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 0e2bb98b0c..3dc7917e42 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -24,7 +24,16 @@ newTransferSlots :: IO TransferSlots
 newTransferSlots = newQSemN numSlots
 
 {- Waits until a transfer slot becomes available, and runs a transfer
- - action in the slot.
+ - action in the slot. If the action throws an exception, its slot is
+ - freed here, otherwise it should be freed by the TransferWatcher when
+ - the transfer is complete.
  -}
 inTransferSlot :: TransferSlots -> IO a -> IO a
-inTransferSlot s = bracket_ (waitQSemN s 1) (signalQSemN s 1)
+inTransferSlot s a = bracketOnError
+	(waitQSemN s 1)
+	(const $ signalQSemN s 1)
+	(const a)
+
+{- Call when a transfer is complete. -}
+transferComplete :: TransferSlots -> IO ()
+transferComplete s = signalQSemN s 1