diff --git a/Annex.hs b/Annex.hs index 748ad96009..ed2aaf011c 100644 --- a/Annex.hs +++ b/Annex.hs @@ -70,6 +70,7 @@ import Types.WorkerPool import Types.IndexFiles import Types.CatFileHandles import Types.RemoteConfig +import Types.TransferrerPool import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url @@ -156,6 +157,7 @@ data AnnexState = AnnexState , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) , urloptions :: Maybe UrlOptions , insmudgecleanfilter :: Bool + , transferrerpool :: TransferrerPool } newState :: GitConfig -> Git.Repo -> IO AnnexState @@ -165,6 +167,7 @@ newState c r = do o <- newMessageState sc <- newTMVarIO False kh <- Keys.newDbHandle + tp <- newTransferrerPool return $ AnnexState { repo = r , repoadjustment = return @@ -217,6 +220,7 @@ newState c r = do , cachedgitenv = Nothing , urloptions = Nothing , insmudgecleanfilter = False + , transferrerpool = tp } {- Makes an Annex state object for the specified git repo. diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs index 7edfecd49e..286c6f9be2 100644 --- a/Annex/TransferrerPool.hs +++ b/Annex/TransferrerPool.hs @@ -27,11 +27,11 @@ import Control.Monad.IO.Class (MonadIO) - it's stopped when done. Otherwise, idle processes are left in the pool - for use later. -} -withTransferrer :: Bool -> FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a -withTransferrer minimizeprocesses program batchmaker pool a = do +withTransferrer :: Bool -> MkCheckTransferrer -> FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a +withTransferrer minimizeprocesses mkcheck program batchmaker pool a = do (mi, leftinpool) <- atomically (popTransferrerPool pool) i@(TransferrerPoolItem (Just t) check) <- case mi of - Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker + Nothing -> mkTransferrerPoolItem mkcheck =<< mkTransferrer program batchmaker Just i -> checkTransferrerPoolItem program batchmaker i a t `finally` returntopool leftinpool check t i where diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index fc45bd7991..ff79f5f173 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -35,7 +35,6 @@ import Assistant.Types.DaemonStatus import Assistant.Types.ScanRemotes import Assistant.Types.TransferQueue import Assistant.Types.TransferSlots -import Assistant.Types.TransferrerPool import Assistant.Types.Pushes import Assistant.Types.BranchChange import Assistant.Types.Commits @@ -65,7 +64,6 @@ data AssistantData = AssistantData , scanRemoteMap :: ScanRemoteMap , transferQueue :: TransferQueue , transferSlots :: TransferSlots - , transferrerPool :: TransferrerPool , failedPushMap :: FailedPushMap , failedExportMap :: FailedPushMap , commitChan :: CommitChan @@ -85,7 +83,6 @@ newAssistantData st dstatus = AssistantData <*> newScanRemoteMap <*> newTransferQueue <*> newTransferSlots - <*> newTransferrerPool (checkNetworkConnections dstatus) <*> newFailedPushMap <*> newFailedPushMap <*> newCommitChan diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 80aeaaca6b..89788ca9f0 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -1,6 +1,6 @@ {- git-annex assistant transfer slots - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,12 +9,15 @@ module Assistant.TransferSlots where +import Control.Concurrent.STM + import Assistant.Common import Utility.ThreadScheduler +import Utility.NotificationBroadcaster import Assistant.Types.TransferSlots import Assistant.DaemonStatus import Annex.TransferrerPool -import Assistant.Types.TransferrerPool +import Types.TransferrerPool import Assistant.Types.TransferQueue import Assistant.TransferQueue import Assistant.Alert @@ -25,6 +28,7 @@ import Types.Transfer import Logs.Transfer import Logs.Location import qualified Git +import qualified Annex import qualified Remote import qualified Types.Remote as Remote import Annex.Content @@ -75,15 +79,19 @@ runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferI runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots runTransferThread program batchmaker (Just (t, info, a)) = do d <- getAssistant id + mkcheck <- checkNetworkConnections + <$> getAssistant daemonStatusHandle aio <- asIO1 a - tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio + tid <- liftIO $ forkIO $ runTransferThread' mkcheck program batchmaker d aio updateTransferInfo t $ info { transferTid = Just tid } -runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO () -runTransferThread' program batchmaker d run = go +runTransferThread' :: MkCheckTransferrer -> FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO () +runTransferThread' mkcheck program batchmaker d run = go where - go = catchPauseResume $ - withTransferrer True program batchmaker (transferrerPool d) + go = catchPauseResume $ do + p <- runAssistant d $ liftAnnex $ + Annex.getState Annex.transferrerpool + withTransferrer True mkcheck program batchmaker p run pause = catchPauseResume $ runEvery (Seconds 86400) noop @@ -298,3 +306,9 @@ startTransfer t = do getCurrentTransfers :: Assistant TransferMap getCurrentTransfers = currentTransfers <$> getDaemonStatus + +checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer +checkNetworkConnections dstatushandle = do + dstatus <- atomically $ readTVar dstatushandle + h <- newNotificationHandle False (networkConnectedNotifier dstatus) + return $ not <$> checkNotification h diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs deleted file mode 100644 index 65c49d5140..0000000000 --- a/Assistant/Types/TransferrerPool.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- A pool of "git-annex transferkeys" processes available for use - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Assistant.Types.TransferrerPool ( - module Types.TransferrerPool, - checkNetworkConnections, -) where - -import Types.TransferrerPool -import Utility.NotificationBroadcaster -import Assistant.Types.DaemonStatus - -import Control.Concurrent.STM - -checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer -checkNetworkConnections dstatushandle = do - dstatus <- atomically $ readTVar dstatushandle - h <- newNotificationHandle False (networkConnectedNotifier dstatus) - return $ not <$> checkNotification h diff --git a/Types/TransferrerPool.hs b/Types/TransferrerPool.hs index e6019f27f0..72d61a3b9a 100644 --- a/Types/TransferrerPool.hs +++ b/Types/TransferrerPool.hs @@ -7,11 +7,11 @@ module Types.TransferrerPool where -import Annex.Common +import Common import Control.Concurrent.STM hiding (check) -type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem]) +type TransferrerPool = TVar [TransferrerPoolItem] type CheckTransferrer = IO Bool type MkCheckTransferrer = IO (IO Bool) @@ -27,30 +27,29 @@ data Transferrer = Transferrer , transferrerHandle :: ProcessHandle } -newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool -newTransferrerPool c = newTVarIO (c, []) +newTransferrerPool :: IO TransferrerPool +newTransferrerPool = newTVarIO [] popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int) popTransferrerPool p = do - (c, l) <- readTVar p + l <- readTVar p case l of [] -> return (Nothing, 0) (i:is) -> do - writeTVar p (c, is) + writeTVar p is return $ (Just i, length is) pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM () pushTransferrerPool p i = do - (c, l) <- readTVar p + l <- readTVar p let l' = i:l - writeTVar p (c, l') + writeTVar p 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 <$> readTVar p +mkTransferrerPoolItem :: MkCheckTransferrer -> Transferrer -> IO TransferrerPoolItem +mkTransferrerPoolItem mkcheck t = do check <- mkcheck return $ TransferrerPoolItem (Just t) check diff --git a/git-annex.cabal b/git-annex.cabal index b527b6b15c..43e3249347 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -494,7 +494,6 @@ Executable git-annex Assistant.Types.ThreadedMonad Assistant.Types.TransferQueue Assistant.Types.TransferSlots - Assistant.Types.TransferrerPool Assistant.Types.UrlRenderer Assistant.Unused Assistant.Upgrade