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 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.