autoEnableSpecialRemotes = do
rp <- fromRawFilePath <$> fromRepo Git.repoPath
withNullHandle $ \nullh -> gitAnnexChildProcess "init"
- [ "--autoenable" ]
+ [ Param "--autoenable" ]
(\p -> p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
-}
gitAnnexChildProcess
:: String
- -> [String]
+ -> [CommandParam]
-> (CreateProcess -> CreateProcess)
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> Annex a
gitAnnexChildProcess subcmd ps f a = do
cmd <- liftIO programPath
- -- Pass along git config values that were set on command line
- -- to the child process.
- cps <- concatMap (\c -> ["-c", c]) <$> Annex.getGitConfigOverrides
- pidLockChildProcess cmd (subcmd:cps++ps) f a
+ ps' <- gitAnnexChildProcessParams subcmd ps
+ pidLockChildProcess cmd ps' f a
+
+{- Parameters to pass to a git-annex child process to run a subcommand
+ - with some parameters.
+ -
+ - Includes -c values that were passed on the git-annex command line.
+ -}
+gitAnnexChildProcessParams :: String -> [CommandParam] -> Annex [CommandParam]
+gitAnnexChildProcessParams subcmd ps = do
+ cps <- concatMap (\c -> [Param "-c", Param c]) <$> Annex.getGitConfigOverrides
+ return (Param subcmd : cps ++ ps)
-}
pidLockChildProcess
:: FilePath
- -> [String]
+ -> [CommandParam]
-> (CreateProcess -> CreateProcess)
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> Annex a
pidLockChildProcess cmd ps f a = do
- let p = f (proc cmd ps)
+ let p = f (proc cmd (toCommand ps))
let gonopidlock = withCreateProcess p a
#ifndef mingw32_HOST_OS
pidLockFile >>= liftIO . \case
type SignalActionsVar = TVar (M.Map SignalAction (Int -> IO ()))
+data RunTransferrer = RunTransferrer String [CommandParam] BatchCommandMaker
+
+mkRunTransferrer :: BatchCommandMaker -> Annex RunTransferrer
+mkRunTransferrer batchmaker = RunTransferrer
+ <$> liftIO programPath
+ <*> gitAnnexChildProcessParams "transferrer" []
+ <*> pure batchmaker
+
{- Runs an action with a Transferrer from the pool. -}
withTransferrer :: (Transferrer -> Annex a) -> Annex a
withTransferrer a = do
- program <- liftIO programPath
+ rt <- mkRunTransferrer nonBatchCommandMaker
pool <- Annex.getState Annex.transferrerpool
let nocheck = pure (pure True)
signalactonsvar <- Annex.getState Annex.signalactions
- withTransferrer' False signalactonsvar nocheck program nonBatchCommandMaker pool a
+ withTransferrer' False signalactonsvar nocheck rt pool a
withTransferrer'
:: (MonadIO m, MonadMask m)
-- processes are left in the pool for use later.
-> SignalActionsVar
-> MkCheckTransferrer
- -> FilePath
- -> BatchCommandMaker
+ -> RunTransferrer
-> TransferrerPool
-> (Transferrer -> m a)
-> m a
-withTransferrer' minimizeprocesses signalactonsvar mkcheck program batchmaker pool a = do
+withTransferrer' minimizeprocesses signalactonsvar mkcheck rt pool a = do
(mi, leftinpool) <- liftIO $ atomically (popTransferrerPool pool)
(i@(TransferrerPoolItem _ check), t) <- liftIO $ case mi of
Nothing -> do
- t <- mkTransferrer signalactonsvar program batchmaker
+ t <- mkTransferrer signalactonsvar rt
i <- mkTransferrerPoolItem mkcheck t
return (i, t)
- Just i -> checkTransferrerPoolItem signalactonsvar program batchmaker i
+ Just i -> checkTransferrerPoolItem signalactonsvar rt i
a t `finally` returntopool leftinpool check t i
where
returntopool leftinpool check t i
{- Check if a Transferrer from the pool is still ok to be used.
- If not, stop it and start a new one. -}
-checkTransferrerPoolItem :: SignalActionsVar -> FilePath -> BatchCommandMaker -> TransferrerPoolItem -> IO (TransferrerPoolItem, Transferrer)
-checkTransferrerPoolItem signalactonsvar program batchmaker i = case i of
+checkTransferrerPoolItem :: SignalActionsVar -> RunTransferrer -> TransferrerPoolItem -> IO (TransferrerPoolItem, Transferrer)
+checkTransferrerPoolItem signalactonsvar rt i = case i of
TransferrerPoolItem (Just t) check -> ifM check
( return (i, t)
, do
TransferrerPoolItem Nothing check -> new check
where
new check = do
- t <- mkTransferrer signalactonsvar program batchmaker
+ t <- mkTransferrer signalactonsvar rt
return (TransferrerPoolItem (Just t) check, t)
data TransferRequestLevel = AnnexLevel | AssistantLevel
{- Starts a new git-annex transfer process, setting up handles
- that will be used to communicate with it. -}
-mkTransferrer :: SignalActionsVar -> FilePath -> BatchCommandMaker -> IO Transferrer
-mkTransferrer signalactonsvar program batchmaker = do
+mkTransferrer :: SignalActionsVar -> RunTransferrer -> IO Transferrer
+mkTransferrer signalactonsvar (RunTransferrer program params batchmaker) = do
{- It runs as a batch job. -}
- let (program', params') = batchmaker (program, [Param "transferrer"])
+ let (program', params') = batchmaker (program, params)
{- It's put into its own group so that the whole group can be
- killed to stop a transfer. -}
(Just writeh, Just readh, _, ph) <- createProcess
import Assistant.TransferQueue
import Assistant.TransferSlots
import Types.Transfer
-import Annex.Path
+import Annex.TransferrerPool
import Utility.Batch
{- Dispatches transfers from the queue. -}
transfererThread :: NamedThread
transfererThread = namedThread "Transferrer" $ do
- program <- liftIO programPath
- batchmaker <- liftIO getBatchCommandMaker
- forever $ inTransferSlot program batchmaker $
+ rt <- liftAnnex . mkRunTransferrer
+ =<< liftIO getBatchCommandMaker
+ forever $ inTransferSlot rt $
maybe (return Nothing) (uncurry genTransfer)
=<< getNextTransfer notrunning
where
import qualified Types.Remote as Remote
import Annex.Content
import Annex.Wanted
-import Annex.Path
import Utility.Batch
import Types.NumCopies
{- Waits until a transfer slot becomes available, then runs a
- TransferGenerator, and then runs the transfer action in its own thread.
-}
-inTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
-inTransferSlot program batchmaker gen = do
+inTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant ()
+inTransferSlot rt gen = do
flip MSemN.wait 1 <<~ transferSlots
- runTransferThread program batchmaker =<< gen
+ runTransferThread rt =<< gen
{- Runs a TransferGenerator, and its transfer action,
- without waiting for a slot to become available. -}
-inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
-inImmediateTransferSlot program batchmaker gen = do
+inImmediateTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant ()
+inImmediateTransferSlot rt gen = do
flip MSemN.signal (-1) <<~ transferSlots
- runTransferThread program batchmaker =<< gen
+ runTransferThread rt =<< gen
{- Runs a transfer action, in an already allocated transfer slot.
- Once it finishes, frees the transfer slot.
- then pausing the thread until a ResumeTransfer exception is raised,
- then rerunning the action.
-}
-runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
-runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots
-runTransferThread program batchmaker (Just (t, info, a)) = do
+runTransferThread :: RunTransferrer -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
+runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots
+runTransferThread rt (Just (t, info, a)) = do
d <- getAssistant id
mkcheck <- checkNetworkConnections
<$> getAssistant daemonStatusHandle
aio <- asIO1 a
- tid <- liftIO $ forkIO $ runTransferThread' mkcheck program batchmaker d aio
+ tid <- liftIO $ forkIO $ runTransferThread' mkcheck rt d aio
updateTransferInfo t $ info { transferTid = Just tid }
-runTransferThread' :: MkCheckTransferrer -> FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO ()
-runTransferThread' mkcheck program batchmaker d run = go
+runTransferThread' :: MkCheckTransferrer -> RunTransferrer -> AssistantData -> (Transferrer -> IO ()) -> IO ()
+runTransferThread' mkcheck rt d run = go
where
go = catchPauseResume $ do
p <- runAssistant d $ liftAnnex $
Annex.getState Annex.transferrerpool
signalactonsvar <- runAssistant d $ liftAnnex $
Annex.getState Annex.signalactions
- withTransferrer' True signalactonsvar mkcheck program batchmaker p run
+ withTransferrer' True signalactonsvar mkcheck rt p run
pause = catchPauseResume $
runEvery (Seconds 86400) noop
{- Note: This must use E.try, rather than E.catch.
alterTransferInfo t $ \i -> i { transferPaused = False }
liftIO $ throwTo tid ResumeTransfer
start info = do
- program <- liftIO programPath
- batchmaker <- liftIO getBatchCommandMaker
- inImmediateTransferSlot program batchmaker $
+ rt <- liftAnnex . mkRunTransferrer
+ =<< liftIO getBatchCommandMaker
+ inImmediateTransferSlot rt $
genTransfer t info
getCurrentTransfers :: Assistant TransferMap
upgraderemote = do
rp <- fromRawFilePath <$> fromRepo Git.repoPath
gitAnnexChildProcess "upgrade"
- [ "--quiet"
- , "--autoonly"
+ [ Param "--quiet"
+ , Param "--autoonly"
]
(\p -> p { cwd = Just rp })
(\_ _ _ pid -> waitForProcess pid >>= return . \case
-When `git -c foo.bar annex` runs git-annex transferrer,
+When `git annex -c foo.bar` runs git-annex transferrer,
it does not pass along the settings from -c.
+(Note that, `git -c foo.bar annex` does propagate the -c. Git does it by
+setting an environment variable, which causes git config to reflect the
+override. The environment variable propagates to child processes.)
+
There are a lot of config settings that impact transfers,
and some of them might be commonly used at the command line, so something
needs to be done about this. --[[Joey]]
+
+> [[done]]
projects / git-annex.git / commitdiff