mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

tested transferkeys restarting; fix some bugs

Browse source
This commit is contained in:
Joey Hess 2014-01-06 17:07:08 -04:00
parent 375842aee8
commit 5279c4d1df
2 changed files with 15 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

16
Assistant/TransferrerPool.hs
View file

@ -26,14 +26,16 @@ import Control.Concurrent
-} -}
withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a
withTransferrer program batchmaker pool a = do withTransferrer program batchmaker pool a = do
i@(TransferrerPoolItem (Just t) _) <- maybe (mi, leftinpool) <- atomically (popTransferrerPool pool)
(mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker) i@(TransferrerPoolItem (Just t) check) <- case mi of
(checkTransferrerPoolItem program batchmaker) Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker
=<< atomically (popTransferrerPool pool) Just i -> checkTransferrerPoolItem program batchmaker i
v <- tryNonAsync $ a t v <- tryNonAsync $ a t
sz <- atomically $ pushTransferrerPool pool i if leftinpool == 0
when (sz > 1) $ then atomically $ pushTransferrerPool pool i
void $ forkIO $ stopTransferrer t else do
void $ forkIO $ stopTransferrer t
atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check
either throw return v either throw return v
{- Check if a Transferrer from the pool is still ok to be used. {- Check if a Transferrer from the pool is still ok to be used.

13
Assistant/Types/TransferrerPool.hs
View file

@ -11,7 +11,7 @@ import Common.Annex
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Assistant.Types.DaemonStatus import Assistant.Types.DaemonStatus
import Control.Concurrent.STM import Control.Concurrent.STM hiding (check)
{- This TMVar is never left empty. -} {- This TMVar is never left empty. -}
type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem]) type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem])
@ -33,23 +33,22 @@ data Transferrer = Transferrer
newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool
newTransferrerPool c = newTMVarIO (c, []) newTransferrerPool c = newTMVarIO (c, [])
popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem) popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)
popTransferrerPool p = do popTransferrerPool p = do
(c, l) <- takeTMVar p (c, l) <- takeTMVar p
case l of case l of
[] -> do [] -> do
putTMVar p (c, []) putTMVar p (c, [])
return Nothing return (Nothing, 0)
(i:is) -> do (i:is) -> do
putTMVar p (c, is) 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 pushTransferrerPool p i = do
(c, l) <- takeTMVar p (c, l) <- takeTMVar p
let l' = i:l let l' = i:l
putTMVar p (c, l') putTMVar p (c, l')
return $ length l'
{- Note that making a CheckTransferrer may allocate resources, {- Note that making a CheckTransferrer may allocate resources,
- such as a NotificationHandle, so it's important that the returned - such as a NotificationHandle, so it's important that the returned
@ -65,4 +64,4 @@ checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer
checkNetworkConnections dstatushandle = do checkNetworkConnections dstatushandle = do
dstatus <- atomically $ readTMVar dstatushandle dstatus <- atomically $ readTMVar dstatushandle
h <- newNotificationHandle False (networkConnectedNotifier dstatus) h <- newNotificationHandle False (networkConnectedNotifier dstatus)
return $ checkNotification h return $ not <$> checkNotification h