differentiate between concurrency enabled at command line and by git config

The latter should not affect --batch mode.

diff --git a/Annex.hs b/Annex.hs
index 64ab9c0d74bcd8ca5c78e43416f37cbee7ae1bb1..13695c99864329541f237009e400f80989237b3f 100644 (file)
--- a/Annex.hs
+++ b/Annex.hs
@@ -112,7 +112,7 @@ data AnnexState = AnnexState
        , backend :: Maybe (BackendA Annex)
        , remotes :: [Types.Remote.RemoteA Annex]
        , output :: MessageState
-       , concurrency :: Concurrency
+       , concurrency :: ConcurrencySetting
        , force :: Bool
        , fast :: Bool
        , daemon :: Bool
@@ -171,7 +171,7 @@ newState c r = do
                , backend = Nothing
                , remotes = []
                , output = o
-               , concurrency = NonConcurrent
+               , concurrency = ConcurrencyCmdLine NonConcurrent
                , force = False
                , fast = False
                , daemon = False

diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs
index b4afaffc0a835eafc7caed790ba0ae086441cdd1..856555bbe8e862479a570b571192e77a4bc38a95 100644 (file)
--- a/Annex/Concurrent.hs
+++ b/Annex/Concurrent.hs
@@ -5,10 +5,14 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-module Annex.Concurrent where
+module Annex.Concurrent (
+       module Annex.Concurrent,
+       module Annex.Concurrent.Utility
+) where
 
 import Annex
 import Annex.Common
+import Annex.Concurrent.Utility
 import qualified Annex.Queue
 import Annex.Action
 import Types.Concurrency
@@ -22,19 +26,24 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import qualified Data.Map as M
 
-setConcurrency :: Concurrency -> Annex ()
-setConcurrency NonConcurrent = Annex.changeState $ \s -> s 
-       { Annex.concurrency = NonConcurrent
-       }
-setConcurrency c = do
-       cfh <- Annex.getState Annex.catfilehandles
+setConcurrency :: ConcurrencySetting -> Annex ()
+setConcurrency (ConcurrencyCmdLine s) = setConcurrency' s ConcurrencyCmdLine
+setConcurrency (ConcurrencyGitConfig s) = setConcurrency' s ConcurrencyGitConfig
+
+setConcurrency' :: Concurrency -> (Concurrency -> ConcurrencySetting) -> Annex ()
+setConcurrency' NonConcurrent f = 
+       Annex.changeState $ \s -> s 
+               { Annex.concurrency = f NonConcurrent
+               }
+setConcurrency' c f = do
+       cfh <- getState Annex.catfilehandles
        cfh' <- case cfh of
                CatFileHandlesNonConcurrent _ -> liftIO catFileHandlesPool
                CatFileHandlesPool _ -> pure cfh
        cah <- mkConcurrentCheckAttrHandle c
        cih <- mkConcurrentCheckIgnoreHandle c
        Annex.changeState $ \s -> s
-               { Annex.concurrency = c
+               { Annex.concurrency = f c
                , Annex.catfilehandles = cfh'
                , Annex.checkattrhandle = Just cah
                , Annex.checkignorehandle = Just cih
@@ -74,9 +83,9 @@ dupState = do
        st <- Annex.getState id
        -- Make sure that concurrency is enabled, if it was not already,
        -- so the concurrency-safe resource pools are set up.
-       st' <- case Annex.concurrency st of
+       st' <- case getConcurrency' (Annex.concurrency st) of
                NonConcurrent -> do
-                       setConcurrency (Concurrent 1)
+                       setConcurrency (ConcurrencyCmdLine (Concurrent 1))
                        Annex.getState id
                _ -> return st
        return $ st'

diff --git a/Annex/Concurrent/Utility.hs b/Annex/Concurrent/Utility.hs
index 0521f6ba5d9d8bc6472cb7de37598c87c5e028f8..2810f6da6b0c06e44a0e7910b91c5032edd1cedd 100644 (file)
--- a/Annex/Concurrent/Utility.hs
+++ b/Annex/Concurrent/Utility.hs
@@ -7,10 +7,18 @@
 
 module Annex.Concurrent.Utility where
 
+import Annex
 import Types.Concurrency
 
 import GHC.Conc
 
+getConcurrency :: Annex Concurrency
+getConcurrency = getConcurrency' <$> getState concurrency
+
+getConcurrency' :: ConcurrencySetting -> Concurrency
+getConcurrency' (ConcurrencyCmdLine c) = c
+getConcurrency' (ConcurrencyGitConfig c) = c
+
 {- Honor the requested level of concurrency, but only up to the number of
  - CPU cores. Useful for things that are known to be CPU bound. -}
 concurrencyUpToCpus :: Concurrency -> IO Int

diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index f202add142f51ede6b29d6e76bca85325174e00c..b19e54527e0dc5da26c340f9f387e13c3c72ef0a 100644 (file)
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -34,6 +34,7 @@ import Annex.Path
 import Utility.Env
 import Utility.Hash
 import Types.CleanupActions
+import Annex.Concurrent.Utility
 import Types.Concurrency
 import Git.Env
 import Git.Ssh
@@ -107,7 +108,7 @@ sshCachingInfo (host, port) = go =<< sshCacheDir'
        -- No connection caching with concurrency is not a good
        -- combination, so warn the user.
        go (Left whynocaching) = do
-               Annex.getState Annex.concurrency >>= \case
+               getConcurrency >>= \case
                        NonConcurrent -> return ()
                        Concurrent {} -> warnnocaching whynocaching
                        ConcurrentPerCpu -> warnnocaching whynocaching
@@ -229,7 +230,7 @@ prepSocket socketfile sshhost sshparams = do
        
        let socketlock = socket2lock socketfile
 
-       Annex.getState Annex.concurrency >>= \case
+       getConcurrency >>= \case
                NonConcurrent -> return ()
                Concurrent {} -> makeconnection socketlock
                ConcurrentPerCpu -> makeconnection socketlock

diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index 3414431de19ca5f482a1784da30db5d08ae7af28..f2321a7f36946d7165b26fefd6c1d7b5ab11e5db 100644 (file)
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -31,6 +31,7 @@ import Annex.LockPool
 import Types.Key
 import qualified Types.Remote as Remote
 import Types.Concurrency
+import Annex.Concurrent.Utility
 import Types.WorkerPool
 import Annex.WorkerPool
 import Backend (isCryptographicallySecure)
@@ -262,7 +263,7 @@ configuredRetry numretries _old new = do
  - increase total transfer speed.
  -}
 pickRemote :: Observable v => [Remote] -> (Remote -> Annex v) -> Annex v
-pickRemote l a = debugLocks $ go l =<< Annex.getState Annex.concurrency
+pickRemote l a = debugLocks $ go l =<< getConcurrency
   where
        go [] _ = return observeFailure
        go (r:[]) _ = a r

diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs
index a308488876d202062f63c3fced2906e2c231e5d7..591c590b9af17020cf86e4251b91c0333d7c0677 100644 (file)
--- a/CmdLine/Action.hs
+++ b/CmdLine/Action.hs
@@ -53,7 +53,7 @@ commandActions = mapM_ commandAction
  - This should only be run in the seek stage.
  -}
 commandAction :: CommandStart -> Annex ()
-commandAction start = Annex.getState Annex.concurrency >>= \case
+commandAction start = getConcurrency >>= \case
        NonConcurrent -> runnonconcurrent
        Concurrent _ -> runconcurrent
        ConcurrentPerCpu -> runconcurrent
@@ -200,9 +200,9 @@ performCommandAction' startmsg perform =
  -}
 startConcurrency :: UsedStages -> Annex a -> Annex a
 startConcurrency usedstages a = do
-       fromcmdline <- Annex.getState Annex.concurrency
+       fromcmdline <- getConcurrency
        fromgitcfg <- annexJobs <$> Annex.getGitConfig
-       let usegitcfg = setConcurrency fromgitcfg
+       let usegitcfg = setConcurrency (ConcurrencyGitConfig fromgitcfg)
        case (fromcmdline, fromgitcfg) of
                (NonConcurrent, NonConcurrent) -> a
                (Concurrent n, _) ->
@@ -258,7 +258,7 @@ startConcurrency usedstages a = do
  - May be called repeatedly by the same thread without blocking. -}
 ensureOnlyActionOn :: Key -> Annex a -> Annex a
 ensureOnlyActionOn k a = debugLocks $
-       go =<< Annex.getState Annex.concurrency
+       go =<< getConcurrency
   where
        go NonConcurrent = a
        go (Concurrent _) = goconcurrent

diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs
index 10cb613a36036b9e0fa1cebec739789cdce78a52..22f07045cecbbd155e47876478fb9a52dc6666aa 100644 (file)
--- a/CmdLine/GitAnnex/Options.hs
+++ b/CmdLine/GitAnnex/Options.hs
@@ -392,7 +392,7 @@ jsonProgressOption =
 -- action in `allowConcurrentOutput`.
 jobsOption :: [GlobalOption]
 jobsOption = 
-       [ globalSetter setConcurrency $ 
+       [ globalSetter (setConcurrency . ConcurrencyCmdLine) $ 
                option (maybeReader parseConcurrency)
                        ( long "jobs" <> short 'J' 
                        <> metavar (paramNumber `paramOr` "cpus")

diff --git a/Messages.hs b/Messages.hs
index 324f47b167213919c70675caf3431b4669e5d1f7..07b152c24ae1f4d69d078603e460d9daf0cf4f56 100644 (file)
--- a/Messages.hs
+++ b/Messages.hs
@@ -68,6 +68,7 @@ import Types.Command (StartMessage(..), SeekInput)
 import Types.Transfer (transferKey)
 import Messages.Internal
 import Messages.Concurrent
+import Annex.Concurrent.Utility
 import qualified Messages.JSON as JSON
 import qualified Annex
 
@@ -298,7 +299,7 @@ prompt a = do
 
 {- Like prompt, but for a non-annex action that prompts. -}
 mkPrompter :: (MonadMask m, MonadIO m) => Annex (m a -> m a)
-mkPrompter = Annex.getState Annex.concurrency >>= \case
+mkPrompter = getConcurrency >>= \case
        NonConcurrent -> return id
        (Concurrent _) -> goconcurrent
        ConcurrentPerCpu -> goconcurrent

diff --git a/Types/Concurrency.hs b/Types/Concurrency.hs
index abae4a7729e28e04226929164be421d4391f0cfe..ccab1ee0a910d413a566becdec3ffa64a03fc9e5 100644 (file)
--- a/Types/Concurrency.hs
+++ b/Types/Concurrency.hs
@@ -17,3 +17,8 @@ parseConcurrency :: String -> Maybe Concurrency
 parseConcurrency "cpus" = Just ConcurrentPerCpu
 parseConcurrency "cpu" = Just ConcurrentPerCpu
 parseConcurrency s = Concurrent <$> readish s
+
+-- Concurrency can be configured at the command line or by git config.
+data ConcurrencySetting
+       = ConcurrencyCmdLine Concurrency
+       | ConcurrencyGitConfig Concurrency