tested transferkeys restarting; fix some bugs

2 files changed, 15 insertions, 14 deletions

diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs
index 580417305..6ad9b6b99 100644
--- a/Assistant/TransferrerPool.hs
+++ b/Assistant/TransferrerPool.hs
@@ -26,14 +26,16 @@ import Control.Concurrent
  -}
 withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a
 withTransferrer program batchmaker pool a = do
-	i@(TransferrerPoolItem (Just t) _) <- maybe
-		(mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker)
-		(checkTransferrerPoolItem program batchmaker)
-			=<< atomically (popTransferrerPool pool)
+	(mi, leftinpool) <- atomically (popTransferrerPool pool)
+	i@(TransferrerPoolItem (Just t) check) <- case mi of
+		Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker
+		Just i -> checkTransferrerPoolItem program batchmaker i
 	v <- tryNonAsync $ a t
-	sz <- atomically $ pushTransferrerPool pool i
-	when (sz > 1) $
-		void $ forkIO $ stopTransferrer t
+	if leftinpool == 0
+		then atomically $ pushTransferrerPool pool i
+		else do
+			void $ forkIO $ stopTransferrer t
+			atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check
 	either throw return v
 
 {- Check if a Transferrer from the pool is still ok to be used.
diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs
index 899e6969f..b66fdfa13 100644
--- a/Assistant/Types/TransferrerPool.hs
+++ b/Assistant/Types/TransferrerPool.hs
@@ -11,7 +11,7 @@ import Common.Annex
 import Utility.NotificationBroadcaster
 import Assistant.Types.DaemonStatus
 
-import Control.Concurrent.STM
+import Control.Concurrent.STM hiding (check)
 
 {- This TMVar is never left empty. -}
 type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem])
@@ -33,23 +33,22 @@ data Transferrer = Transferrer
 newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool
 newTransferrerPool c = newTMVarIO (c, [])
 
-popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem)
+popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)
 popTransferrerPool p = do
 	(c, l) <- takeTMVar p
 	case l of
 		[] -> do
 			putTMVar p (c, [])
-			return Nothing
+			return (Nothing, 0)
 		(i:is) -> do
 			putTMVar p (c, is)
-			return $ Just i
+			return $ (Just i, length is)
 
-pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM Int
+pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()
 pushTransferrerPool p i = do
 	(c, l) <- takeTMVar p
 	let l' = i:l
 	putTMVar p (c, l')
-	return $ length l'
 
 {- Note that making a CheckTransferrer may allocate resources,
  - such as a NotificationHandle, so it's important that the returned
@@ -65,4 +64,4 @@ checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer
 checkNetworkConnections dstatushandle = do
 	dstatus <- atomically $ readTMVar dstatushandle
 	h <- newNotificationHandle False (networkConnectedNotifier dstatus)
-	return $ checkNotification h
+	return $ not <$> checkNotification h