1 files changed, 49 insertions, 4 deletions
diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs
index 2727a6919..899e6969f 100644
--- a/Assistant/Types/TransferrerPool.hs
+++ b/Assistant/Types/TransferrerPool.hs
@@ -1,4 +1,4 @@
-{- A pool of "git-annex transferkeys" processes
+{- A pool of "git-annex transferkeys" processes available for use
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
@@ -8,10 +8,21 @@
 module Assistant.Types.TransferrerPool where
 
 import Common.Annex
+import Utility.NotificationBroadcaster
+import Assistant.Types.DaemonStatus
 
 import Control.Concurrent.STM
 
-type TransferrerPool = TChan Transferrer
+{- This TMVar is never left empty. -}
+type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem])
+
+type CheckTransferrer = IO Bool
+type MkCheckTransferrer = IO (IO Bool)
+
+{- Each item in the pool may have a transferrer running, and has an
+ - IO action that can be used to check if it's still ok to use the
+ - transferrer. -}
+data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer
 
 data Transferrer = Transferrer
 	{ transferrerRead :: Handle
@@ -19,5 +30,39 @@ data Transferrer = Transferrer
 	, transferrerHandle :: ProcessHandle
 	}
 
-newTransferrerPool :: IO TransferrerPool
-newTransferrerPool = newTChanIO
+newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool
+newTransferrerPool c = newTMVarIO (c, [])
+
+popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem)
+popTransferrerPool p = do
+	(c, l) <- takeTMVar p
+	case l of
+		[] -> do
+			putTMVar p (c, [])
+			return Nothing
+		(i:is) -> do
+			putTMVar p (c, is)
+			return $ Just i
+
+pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM Int
+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
+ - TransferrerPoolItem is pushed into the pool, and not left to be
+ - garbage collected. -}
+mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem
+mkTransferrerPoolItem p t = do
+	mkcheck <- atomically $ fst <$> readTMVar p
+	check <- mkcheck
+	return $ TransferrerPoolItem (Just t) check
+
+checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer
+checkNetworkConnections dstatushandle = do
+	dstatus <- atomically $ readTMVar dstatushandle
+	h <- newNotificationHandle False (networkConnectedNotifier dstatus)
+	return $ checkNotification h