Improve startup time for commands that do not operate on remotes
And for tab completion, by not unnessessarily statting paths to remotes, which used to cause eg, spin-up of removable drives. Got rid of the remotes member of Git.Repo. This was a bit painful. Remote.Git modifies the list of remotes as it reads their configs, so still need a persistent list of remotes. So, put it in as Annex.gitremotes. It's only populated by getGitRemotes, so commands like examinekey that don't care about remotes won't do so. This commit was sponsored by Jake Vosloo on Patreon.
This commit is contained in:
parent
d0fe4d7308
commit
2b66492d6e
22 changed files with 148 additions and 70 deletions
16
Annex.hs
16
Annex.hs
|
@ -1,6 +1,6 @@
|
||||||
{- git-annex monad
|
{- git-annex monad
|
||||||
-
|
-
|
||||||
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
|
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
|
||||||
-
|
-
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
@ -34,12 +34,14 @@ module Annex (
|
||||||
getRemoteGitConfig,
|
getRemoteGitConfig,
|
||||||
withCurrentState,
|
withCurrentState,
|
||||||
changeDirectory,
|
changeDirectory,
|
||||||
|
getGitRemotes,
|
||||||
incError,
|
incError,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import qualified Git.Config
|
import qualified Git.Config
|
||||||
|
import qualified Git.Construct
|
||||||
import Annex.Fixup
|
import Annex.Fixup
|
||||||
import Git.CatFile
|
import Git.CatFile
|
||||||
import Git.HashObject
|
import Git.HashObject
|
||||||
|
@ -98,6 +100,7 @@ data AnnexState = AnnexState
|
||||||
{ repo :: Git.Repo
|
{ repo :: Git.Repo
|
||||||
, repoadjustment :: (Git.Repo -> IO Git.Repo)
|
, repoadjustment :: (Git.Repo -> IO Git.Repo)
|
||||||
, gitconfig :: GitConfig
|
, gitconfig :: GitConfig
|
||||||
|
, gitremotes :: Maybe [Git.Repo]
|
||||||
, backend :: Maybe (BackendA Annex)
|
, backend :: Maybe (BackendA Annex)
|
||||||
, remotes :: [Types.Remote.RemoteA Annex]
|
, remotes :: [Types.Remote.RemoteA Annex]
|
||||||
, remoteannexstate :: M.Map UUID AnnexState
|
, remoteannexstate :: M.Map UUID AnnexState
|
||||||
|
@ -153,6 +156,7 @@ newState c r = do
|
||||||
{ repo = r
|
{ repo = r
|
||||||
, repoadjustment = return
|
, repoadjustment = return
|
||||||
, gitconfig = c
|
, gitconfig = c
|
||||||
|
, gitremotes = Nothing
|
||||||
, backend = Nothing
|
, backend = Nothing
|
||||||
, remotes = []
|
, remotes = []
|
||||||
, remoteannexstate = M.empty
|
, remoteannexstate = M.empty
|
||||||
|
@ -357,3 +361,13 @@ incError = changeState $ \s ->
|
||||||
let ! c = errcounter s + 1
|
let ! c = errcounter s + 1
|
||||||
! s' = s { errcounter = c }
|
! s' = s { errcounter = c }
|
||||||
in s'
|
in s'
|
||||||
|
|
||||||
|
getGitRemotes :: Annex [Git.Repo]
|
||||||
|
getGitRemotes = do
|
||||||
|
s <- getState id
|
||||||
|
case gitremotes s of
|
||||||
|
Just rs -> return rs
|
||||||
|
Nothing -> do
|
||||||
|
rs <- liftIO $ Git.Construct.fromRemotes (repo s)
|
||||||
|
changeState $ \s' -> s' { gitremotes = Just rs }
|
||||||
|
return rs
|
||||||
|
|
|
@ -60,7 +60,6 @@ import Logs.Transitions
|
||||||
import Logs.File
|
import Logs.File
|
||||||
import Logs.Trust.Pure
|
import Logs.Trust.Pure
|
||||||
import Logs.Difference.Pure
|
import Logs.Difference.Pure
|
||||||
import Annex.ReplaceFile
|
|
||||||
import qualified Annex.Queue
|
import qualified Annex.Queue
|
||||||
import Annex.Branch.Transitions
|
import Annex.Branch.Transitions
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
|
|
@ -32,7 +32,6 @@ module Annex.Content.Direct (
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
import Annex.Perms
|
import Annex.Perms
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import Utility.Tmp
|
|
||||||
import Logs.Location
|
import Logs.Location
|
||||||
import Logs.File
|
import Logs.File
|
||||||
import Utility.InodeCache
|
import Utility.InodeCache
|
||||||
|
|
|
@ -10,7 +10,6 @@ module Annex.Fixup where
|
||||||
import Git.Types
|
import Git.Types
|
||||||
import Git.Config
|
import Git.Config
|
||||||
import Types.GitConfig
|
import Types.GitConfig
|
||||||
import qualified Git.Construct as Construct
|
|
||||||
import qualified Git.BuildVersion
|
import qualified Git.BuildVersion
|
||||||
import Utility.Path
|
import Utility.Path
|
||||||
import Utility.SafeCommand
|
import Utility.SafeCommand
|
||||||
|
@ -30,7 +29,7 @@ fixupRepo r c = do
|
||||||
let r' = disableWildcardExpansion r
|
let r' = disableWildcardExpansion r
|
||||||
r'' <- fixupSubmodule r' c
|
r'' <- fixupSubmodule r' c
|
||||||
if annexDirect c
|
if annexDirect c
|
||||||
then fixupDirect r''
|
then return (fixupDirect r'')
|
||||||
else return r''
|
else return r''
|
||||||
|
|
||||||
{- Disable git's built-in wildcard expansion, which is not wanted
|
{- Disable git's built-in wildcard expansion, which is not wanted
|
||||||
|
@ -44,19 +43,16 @@ disableWildcardExpansion r
|
||||||
{- Direct mode repos have core.bare=true, but are not really bare.
|
{- Direct mode repos have core.bare=true, but are not really bare.
|
||||||
- Fix up the Repo to be a non-bare repo, and arrange for git commands
|
- Fix up the Repo to be a non-bare repo, and arrange for git commands
|
||||||
- run by git-annex to be passed parameters that override this setting. -}
|
- run by git-annex to be passed parameters that override this setting. -}
|
||||||
fixupDirect :: Repo -> IO Repo
|
fixupDirect :: Repo -> Repo
|
||||||
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
|
fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
|
||||||
let r' = r
|
r
|
||||||
{ location = l { worktree = Just (parentDir d) }
|
{ location = l { worktree = Just (parentDir d) }
|
||||||
, gitGlobalOpts = gitGlobalOpts r ++
|
, gitGlobalOpts = gitGlobalOpts r ++
|
||||||
[ Param "-c"
|
[ Param "-c"
|
||||||
, Param $ coreBare ++ "=" ++ boolConfig False
|
, Param $ coreBare ++ "=" ++ boolConfig False
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
-- Recalc now that the worktree is correct.
|
fixupDirect r = r
|
||||||
rs' <- Construct.fromRemotes r'
|
|
||||||
return $ r' { remotes = rs' }
|
|
||||||
fixupDirect r = return r
|
|
||||||
|
|
||||||
{- Submodules have their gitdir containing ".git/modules/", and
|
{- Submodules have their gitdir containing ".git/modules/", and
|
||||||
- have core.worktree set, and also have a .git file in the top
|
- have core.worktree set, and also have a .git file in the top
|
||||||
|
|
|
@ -16,6 +16,7 @@ import qualified Remote.Rsync as Rsync
|
||||||
import qualified Remote.GCrypt as GCrypt
|
import qualified Remote.GCrypt as GCrypt
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import qualified Git.Command
|
import qualified Git.Command
|
||||||
|
import qualified Annex
|
||||||
import qualified Annex.SpecialRemote
|
import qualified Annex.SpecialRemote
|
||||||
import Logs.UUID
|
import Logs.UUID
|
||||||
import Logs.Remote
|
import Logs.Remote
|
||||||
|
@ -122,26 +123,26 @@ makeGitRemote basename location = makeRemote basename location $ \name ->
|
||||||
- Returns the name of the remote. -}
|
- Returns the name of the remote. -}
|
||||||
makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
|
makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
|
||||||
makeRemote basename location a = do
|
makeRemote basename location a = do
|
||||||
g <- gitRepo
|
rs <- Annex.getGitRemotes
|
||||||
if not (any samelocation $ Git.remotes g)
|
if not (any samelocation rs)
|
||||||
then do
|
then do
|
||||||
let name = uniqueRemoteName basename 0 g
|
let name = uniqueRemoteName basename 0 rs
|
||||||
a name
|
a name
|
||||||
return name
|
return name
|
||||||
else return basename
|
else return basename
|
||||||
where
|
where
|
||||||
samelocation x = Git.repoLocation x == location
|
samelocation x = Git.repoLocation x == location
|
||||||
|
|
||||||
{- Generate an unused name for a remote, adding a number if
|
{- Given a list of all remotes, generate an unused name for a new
|
||||||
- necessary.
|
- remote, adding a number if necessary.
|
||||||
-
|
-
|
||||||
- Ensures that the returned name is a legal git remote name. -}
|
- Ensures that the returned name is a legal git remote name. -}
|
||||||
uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName
|
uniqueRemoteName :: String -> Int -> [Git.Repo] -> RemoteName
|
||||||
uniqueRemoteName basename n r
|
uniqueRemoteName basename n rs
|
||||||
| null namecollision = name
|
| null namecollision = name
|
||||||
| otherwise = uniqueRemoteName legalbasename (succ n) r
|
| otherwise = uniqueRemoteName legalbasename (succ n) rs
|
||||||
where
|
where
|
||||||
namecollision = filter samename (Git.remotes r)
|
namecollision = filter samename rs
|
||||||
samename x = Git.remoteName x == Just name
|
samename x = Git.remoteName x == Just name
|
||||||
name
|
name
|
||||||
| n == 0 = legalbasename
|
| n == 0 = legalbasename
|
||||||
|
|
|
@ -94,7 +94,7 @@ setRepoConfig uuid mremote oldc newc = do
|
||||||
void uuidMapLoad
|
void uuidMapLoad
|
||||||
when nameChanged $ do
|
when nameChanged $ do
|
||||||
liftAnnex $ do
|
liftAnnex $ do
|
||||||
name <- fromRepo $ uniqueRemoteName (legalName newc) 0
|
name <- uniqueRemoteName (legalName newc) 0 <$> Annex.getGitRemotes
|
||||||
{- git remote rename expects there to be a
|
{- git remote rename expects there to be a
|
||||||
- remote.<name>.fetch, and exits nonzero if
|
- remote.<name>.fetch, and exits nonzero if
|
||||||
- there's not. Special remotes don't normally
|
- there's not. Special remotes don't normally
|
||||||
|
|
|
@ -69,7 +69,7 @@ withNewSecretKey use = do
|
||||||
-}
|
-}
|
||||||
getGCryptRemoteName :: UUID -> String -> Annex RemoteName
|
getGCryptRemoteName :: UUID -> String -> Annex RemoteName
|
||||||
getGCryptRemoteName u repoloc = do
|
getGCryptRemoteName u repoloc = do
|
||||||
tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> gitRepo
|
tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> Annex.getGitRemotes
|
||||||
void $ inRepo $ Git.Command.runBool
|
void $ inRepo $ Git.Command.runBool
|
||||||
[ Param "remote"
|
[ Param "remote"
|
||||||
, Param "add"
|
, Param "add"
|
||||||
|
|
|
@ -13,6 +13,9 @@ git-annex (6.20171215) UNRELEASED; urgency=medium
|
||||||
* git-annex.cabal: Add back custom-setup stanza, so cabal new-build works.
|
* git-annex.cabal: Add back custom-setup stanza, so cabal new-build works.
|
||||||
* Fix several places where files in .git/annex/ were written with modes
|
* Fix several places where files in .git/annex/ were written with modes
|
||||||
that did not take the core.sharedRepository config into account.
|
that did not take the core.sharedRepository config into account.
|
||||||
|
* Improve startup time for commands that do not operate on remotes,
|
||||||
|
and for tab completion, by not unnessessarily statting paths to
|
||||||
|
remotes, which used to cause eg, spin-up of removable drives.
|
||||||
|
|
||||||
-- Joey Hess <id@joeyh.name> Wed, 20 Dec 2017 12:11:46 -0400
|
-- Joey Hess <id@joeyh.name> Wed, 20 Dec 2017 12:11:46 -0400
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{- git-annex command-line option parsing
|
{- git-annex command-line option parsing
|
||||||
-
|
-
|
||||||
- Copyright 2010-2017 Joey Hess <id@joeyh.name>
|
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
|
||||||
-
|
-
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
@ -10,10 +10,12 @@ module CmdLine.GitAnnex.Options where
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
import Options.Applicative.Builder.Internal
|
import Options.Applicative.Builder.Internal
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
|
import qualified Data.Map as M
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
import qualified Git.Config
|
import qualified Git.Config
|
||||||
import qualified Git.Construct
|
import qualified Git.Construct
|
||||||
|
import Git.Remote
|
||||||
import Git.Types
|
import Git.Types
|
||||||
import Types.Key
|
import Types.Key
|
||||||
import Types.TrustLevel
|
import Types.TrustLevel
|
||||||
|
@ -348,9 +350,10 @@ completeRemotes :: HasCompleter f => Mod f a
|
||||||
completeRemotes = completer $ mkCompleter $ \input -> do
|
completeRemotes = completer $ mkCompleter $ \input -> do
|
||||||
r <- maybe (pure Nothing) (Just <$$> Git.Config.read)
|
r <- maybe (pure Nothing) (Just <$$> Git.Config.read)
|
||||||
=<< Git.Construct.fromCwd
|
=<< Git.Construct.fromCwd
|
||||||
return $ filter (input `isPrefixOf`)
|
return $ filter (input `isPrefixOf`) $
|
||||||
(maybe [] (mapMaybe remoteName . remotes) r)
|
map remoteKeyToRemoteName $
|
||||||
|
filter isRemoteKey $
|
||||||
|
maybe [] (M.keys . config) r
|
||||||
|
|
||||||
completeBackends :: HasCompleter f => Mod f a
|
completeBackends :: HasCompleter f => Mod f a
|
||||||
completeBackends = completeWith $
|
completeBackends = completeWith $
|
||||||
|
|
|
@ -36,7 +36,7 @@ seek = withWords start
|
||||||
|
|
||||||
start :: [String] -> CommandStart
|
start :: [String] -> CommandStart
|
||||||
start [] = unknownNameError "Specify the remote to enable."
|
start [] = unknownNameError "Specify the remote to enable."
|
||||||
start (name:rest) = go =<< filter matchingname <$> Annex.fromRepo Git.remotes
|
start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes
|
||||||
where
|
where
|
||||||
matchingname r = Git.remoteName r == Just name
|
matchingname r = Git.remoteName r == Just name
|
||||||
go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest)
|
go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest)
|
||||||
|
@ -104,7 +104,7 @@ unknownNameError prefix = do
|
||||||
else Remote.prettyPrintUUIDsDescs
|
else Remote.prettyPrintUUIDsDescs
|
||||||
"known special remotes"
|
"known special remotes"
|
||||||
descm (M.keys m)
|
descm (M.keys m)
|
||||||
disabledremotes <- filterM isdisabled =<< Annex.fromRepo Git.remotes
|
disabledremotes <- filterM isdisabled =<< Annex.getGitRemotes
|
||||||
let remotesmsg = unlines $ map ("\t" ++) $
|
let remotesmsg = unlines $ map ("\t" ++) $
|
||||||
mapMaybe Git.remoteName disabledremotes
|
mapMaybe Git.remoteName disabledremotes
|
||||||
giveup $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
|
giveup $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
|
||||||
|
|
|
@ -27,6 +27,9 @@ import qualified Utility.Dot as Dot
|
||||||
-- a link from the first repository to the second (its remote)
|
-- a link from the first repository to the second (its remote)
|
||||||
data Link = Link Git.Repo Git.Repo
|
data Link = Link Git.Repo Git.Repo
|
||||||
|
|
||||||
|
-- a repo and its remotes
|
||||||
|
type RepoRemotes = (Git.Repo, [Git.Repo])
|
||||||
|
|
||||||
cmd :: Command
|
cmd :: Command
|
||||||
cmd = dontCheck repoExists $
|
cmd = dontCheck repoExists $
|
||||||
command "map" SectionQuery
|
command "map" SectionQuery
|
||||||
|
@ -76,11 +79,11 @@ runViewer file ((c, ps):rest) = ifM (liftIO $ inPath c)
|
||||||
- the repositories first, followed by uuids that were not matched
|
- the repositories first, followed by uuids that were not matched
|
||||||
- to a repository.
|
- to a repository.
|
||||||
-}
|
-}
|
||||||
drawMap :: [Git.Repo] -> TrustMap -> M.Map UUID String -> String
|
drawMap :: [RepoRemotes] -> TrustMap -> M.Map UUID String -> String
|
||||||
drawMap rs trustmap umap = Dot.graph $ repos ++ others
|
drawMap rs trustmap umap = Dot.graph $ repos ++ others
|
||||||
where
|
where
|
||||||
repos = map (node umap rs trustmap) rs
|
repos = map (node umap (map fst rs) trustmap) rs
|
||||||
ruuids = map getUncachedUUID rs
|
ruuids = map (getUncachedUUID . fst) rs
|
||||||
others = map uuidnode $
|
others = map uuidnode $
|
||||||
filter (\u -> M.lookup u trustmap /= Just DeadTrusted) $
|
filter (\u -> M.lookup u trustmap /= Just DeadTrusted) $
|
||||||
filter (`notElem` ruuids) (M.keys umap)
|
filter (`notElem` ruuids) (M.keys umap)
|
||||||
|
@ -113,13 +116,13 @@ nodeId r =
|
||||||
UUID u -> u
|
UUID u -> u
|
||||||
|
|
||||||
{- A node representing a repo. -}
|
{- A node representing a repo. -}
|
||||||
node :: M.Map UUID String -> [Git.Repo] -> TrustMap -> Git.Repo -> String
|
node :: M.Map UUID String -> [Git.Repo] -> TrustMap -> RepoRemotes -> String
|
||||||
node umap fullinfo trustmap r = unlines $ n:edges
|
node umap fullinfo trustmap (r, rs) = unlines $ n:edges
|
||||||
where
|
where
|
||||||
n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
|
n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
|
||||||
trustDecorate trustmap (getUncachedUUID r) $
|
trustDecorate trustmap (getUncachedUUID r) $
|
||||||
Dot.graphNode (nodeId r) (repoName umap r)
|
Dot.graphNode (nodeId r) (repoName umap r)
|
||||||
edges = map (edge umap fullinfo r) (Git.remotes r)
|
edges = map (edge umap fullinfo r) rs
|
||||||
|
|
||||||
{- An edge between two repos. The second repo is a remote of the first. -}
|
{- An edge between two repos. The second repo is a remote of the first. -}
|
||||||
edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
|
edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
|
||||||
|
@ -149,21 +152,21 @@ trustDecorate trustmap u s = case M.lookup u trustmap of
|
||||||
Nothing -> Dot.fillColor "white" s
|
Nothing -> Dot.fillColor "white" s
|
||||||
|
|
||||||
{- Recursively searches out remotes starting with the specified repo. -}
|
{- Recursively searches out remotes starting with the specified repo. -}
|
||||||
spider :: Git.Repo -> Annex [Git.Repo]
|
spider :: Git.Repo -> Annex [RepoRemotes]
|
||||||
spider r = spider' [r] []
|
spider r = spider' [r] []
|
||||||
spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo]
|
spider' :: [Git.Repo] -> [RepoRemotes] -> Annex [RepoRemotes]
|
||||||
spider' [] known = return known
|
spider' [] known = return known
|
||||||
spider' (r:rs) known
|
spider' (r:rs) known
|
||||||
| any (same r) known = spider' rs known
|
| any (same r) (map fst known) = spider' rs known
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
r' <- scan r
|
r' <- scan r
|
||||||
|
|
||||||
-- The remotes will be relative to r', and need to be
|
-- The remotes will be relative to r', and need to be
|
||||||
-- made absolute for later use.
|
-- made absolute for later use.
|
||||||
remotes <- mapM (absRepo r') (Git.remotes r')
|
remotes <- mapM (absRepo r')
|
||||||
let r'' = r' { Git.remotes = remotes }
|
=<< (liftIO $ Git.Construct.fromRemotes r')
|
||||||
|
|
||||||
spider' (rs ++ remotes) (r'':known)
|
spider' (rs ++ remotes) ((r', remotes):known)
|
||||||
|
|
||||||
{- Converts repos to a common absolute form. -}
|
{- Converts repos to a common absolute form. -}
|
||||||
absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
|
absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
|
||||||
|
@ -260,11 +263,11 @@ tryScan r
|
||||||
|
|
||||||
{- Spidering can find multiple paths to the same repo, so this is used
|
{- Spidering can find multiple paths to the same repo, so this is used
|
||||||
- to combine (really remove) duplicate repos with the same UUID. -}
|
- to combine (really remove) duplicate repos with the same UUID. -}
|
||||||
combineSame :: [Git.Repo] -> [Git.Repo]
|
combineSame :: [RepoRemotes] -> [RepoRemotes]
|
||||||
combineSame = map snd . nubBy sameuuid . map pair
|
combineSame = map snd . nubBy sameuuid . map pair
|
||||||
where
|
where
|
||||||
sameuuid (u1, _) (u2, _) = u1 == u2 && u1 /= NoUUID
|
sameuuid (u1, _) (u2, _) = u1 == u2 && u1 /= NoUUID
|
||||||
pair r = (getUncachedUUID r, r)
|
pair (r, rs) = (getUncachedUUID r, (r, rs))
|
||||||
|
|
||||||
safely :: IO Git.Repo -> IO (Maybe Git.Repo)
|
safely :: IO Git.Repo -> IO (Maybe Git.Repo)
|
||||||
safely a = do
|
safely a = do
|
||||||
|
|
|
@ -76,7 +76,7 @@ seek (Pair, Nothing) = commandAction $ do
|
||||||
unusedPeerRemoteName :: Annex RemoteName
|
unusedPeerRemoteName :: Annex RemoteName
|
||||||
unusedPeerRemoteName = go (1 :: Integer) =<< usednames
|
unusedPeerRemoteName = go (1 :: Integer) =<< usednames
|
||||||
where
|
where
|
||||||
usednames = mapMaybe remoteName . remotes <$> Annex.gitRepo
|
usednames = mapMaybe remoteName <$> Annex.getGitRemotes
|
||||||
go n names = do
|
go n names = do
|
||||||
let name = "peer" ++ show n
|
let name = "peer" ++ show n
|
||||||
if name `elem` names
|
if name `elem` names
|
||||||
|
|
|
@ -13,8 +13,8 @@ import Data.Char
|
||||||
import Common
|
import Common
|
||||||
import Git
|
import Git
|
||||||
import Git.Types
|
import Git.Types
|
||||||
import qualified Git.Construct
|
|
||||||
import qualified Git.Command
|
import qualified Git.Command
|
||||||
|
import qualified Git.Construct
|
||||||
import Utility.UserInfo
|
import Utility.UserInfo
|
||||||
|
|
||||||
{- Returns a single git config setting, or a default value if not set. -}
|
{- Returns a single git config setting, or a default value if not set. -}
|
||||||
|
@ -89,12 +89,10 @@ hRead repo h = do
|
||||||
store :: String -> Repo -> IO Repo
|
store :: String -> Repo -> IO Repo
|
||||||
store s repo = do
|
store s repo = do
|
||||||
let c = parse s
|
let c = parse s
|
||||||
repo' <- updateLocation $ repo
|
updateLocation $ repo
|
||||||
{ config = (M.map Prelude.head c) `M.union` config repo
|
{ config = (M.map Prelude.head c) `M.union` config repo
|
||||||
, fullconfig = M.unionWith (++) c (fullconfig repo)
|
, fullconfig = M.unionWith (++) c (fullconfig repo)
|
||||||
}
|
}
|
||||||
rs <- Git.Construct.fromRemotes repo'
|
|
||||||
return $ repo' { remotes = rs }
|
|
||||||
|
|
||||||
{- Updates the location of a repo, based on its configuration.
|
{- Updates the location of a repo, based on its configuration.
|
||||||
-
|
-
|
||||||
|
|
|
@ -127,8 +127,7 @@ fromRemotes repo = mapM construct remotepairs
|
||||||
where
|
where
|
||||||
filterconfig f = filter f $ M.toList $ config repo
|
filterconfig f = filter f $ M.toList $ config repo
|
||||||
filterkeys f = filterconfig (\(k,_) -> f k)
|
filterkeys f = filterconfig (\(k,_) -> f k)
|
||||||
remotepairs = filterkeys isremote
|
remotepairs = filterkeys isRemoteKey
|
||||||
isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k
|
|
||||||
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
|
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
|
||||||
|
|
||||||
{- Sets the name of a remote when constructing the Repo to represent it. -}
|
{- Sets the name of a remote when constructing the Repo to represent it. -}
|
||||||
|
@ -140,10 +139,7 @@ remoteNamed n constructor = do
|
||||||
{- Sets the name of a remote based on the git config key, such as
|
{- Sets the name of a remote based on the git config key, such as
|
||||||
- "remote.foo.url". -}
|
- "remote.foo.url". -}
|
||||||
remoteNamedFromKey :: String -> IO Repo -> IO Repo
|
remoteNamedFromKey :: String -> IO Repo -> IO Repo
|
||||||
remoteNamedFromKey k = remoteNamed basename
|
remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
|
||||||
where
|
|
||||||
basename = intercalate "." $
|
|
||||||
reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k
|
|
||||||
|
|
||||||
{- Constructs a new Repo for one of a Repo's remotes using a given
|
{- Constructs a new Repo for one of a Repo's remotes using a given
|
||||||
- location (ie, an url). -}
|
- location (ie, an url). -}
|
||||||
|
@ -233,7 +229,6 @@ newFrom l = Repo
|
||||||
{ location = l
|
{ location = l
|
||||||
, config = M.empty
|
, config = M.empty
|
||||||
, fullconfig = M.empty
|
, fullconfig = M.empty
|
||||||
, remotes = []
|
|
||||||
, remoteName = Nothing
|
, remoteName = Nothing
|
||||||
, gitEnv = Nothing
|
, gitEnv = Nothing
|
||||||
, gitEnvOverridesGitDir = False
|
, gitEnvOverridesGitDir = False
|
||||||
|
|
|
@ -20,6 +20,15 @@ import Network.URI
|
||||||
import Git.FilePath
|
import Git.FilePath
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
{- Is a git config key one that specifies the location of a remote? -}
|
||||||
|
isRemoteKey :: String -> Bool
|
||||||
|
isRemoteKey k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k
|
||||||
|
|
||||||
|
{- Get a remote's name from the config key that specifies its location. -}
|
||||||
|
remoteKeyToRemoteName :: String -> RemoteName
|
||||||
|
remoteKeyToRemoteName k = intercalate "." $
|
||||||
|
reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k
|
||||||
|
|
||||||
{- Construct a legal git remote name out of an arbitrary input string.
|
{- Construct a legal git remote name out of an arbitrary input string.
|
||||||
-
|
-
|
||||||
- There seems to be no formal definition of this in the git source,
|
- There seems to be no formal definition of this in the git source,
|
||||||
|
|
|
@ -11,7 +11,6 @@ module Git.Repair (
|
||||||
removeBadBranches,
|
removeBadBranches,
|
||||||
successfulRepair,
|
successfulRepair,
|
||||||
cleanCorruptObjects,
|
cleanCorruptObjects,
|
||||||
retrieveMissingObjects,
|
|
||||||
resetLocalBranches,
|
resetLocalBranches,
|
||||||
checkIndex,
|
checkIndex,
|
||||||
checkIndexFast,
|
checkIndexFast,
|
||||||
|
@ -102,10 +101,11 @@ retrieveMissingObjects missing referencerepo r
|
||||||
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
|
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
|
||||||
error $ "failed to create temp repository in " ++ tmpdir
|
error $ "failed to create temp repository in " ++ tmpdir
|
||||||
tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
|
tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
|
||||||
stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
|
rs <- Construct.fromRemotes r
|
||||||
|
stillmissing <- pullremotes tmpr rs fetchrefstags missing
|
||||||
if S.null (knownMissing stillmissing)
|
if S.null (knownMissing stillmissing)
|
||||||
then return stillmissing
|
then return stillmissing
|
||||||
else pullremotes tmpr (remotes r) fetchallrefs stillmissing
|
else pullremotes tmpr rs fetchallrefs stillmissing
|
||||||
where
|
where
|
||||||
pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
|
pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
|
||||||
Nothing -> return stillmissing
|
Nothing -> return stillmissing
|
||||||
|
|
|
@ -34,8 +34,8 @@ data Repo = Repo
|
||||||
, config :: M.Map String String
|
, config :: M.Map String String
|
||||||
-- a given git config key can actually have multiple values
|
-- a given git config key can actually have multiple values
|
||||||
, fullconfig :: M.Map String [String]
|
, fullconfig :: M.Map String [String]
|
||||||
, remotes :: [Repo]
|
-- remoteName holds the name used for this repo in some other
|
||||||
-- remoteName holds the name used for this repo in remotes
|
-- repo's list of remotes, when this repo is such a remote
|
||||||
, remoteName :: Maybe RemoteName
|
, remoteName :: Maybe RemoteName
|
||||||
-- alternate environment to use when running git commands
|
-- alternate environment to use when running git commands
|
||||||
, gitEnv :: Maybe [(String, String)]
|
, gitEnv :: Maybe [(String, String)]
|
||||||
|
|
|
@ -182,7 +182,7 @@ gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c
|
||||||
(c', _encsetup) <- encryptionSetup c gc
|
(c', _encsetup) <- encryptionSetup c gc
|
||||||
|
|
||||||
let url = Git.GCrypt.urlPrefix ++ gitrepo
|
let url = Git.GCrypt.urlPrefix ++ gitrepo
|
||||||
rs <- fromRepo Git.remotes
|
rs <- Annex.getGitRemotes
|
||||||
case filter (\r -> Git.remoteName r == Just remotename) rs of
|
case filter (\r -> Git.remoteName r == Just remotename) rs of
|
||||||
[] -> inRepo $ Git.Command.run
|
[] -> inRepo $ Git.Command.run
|
||||||
[ Param "remote", Param "add"
|
[ Param "remote", Param "add"
|
||||||
|
|
|
@ -78,7 +78,7 @@ remote = RemoteType
|
||||||
list :: Bool -> Annex [Git.Repo]
|
list :: Bool -> Annex [Git.Repo]
|
||||||
list autoinit = do
|
list autoinit = do
|
||||||
c <- fromRepo Git.config
|
c <- fromRepo Git.config
|
||||||
rs <- mapM (tweakurl c) =<< fromRepo Git.remotes
|
rs <- mapM (tweakurl c) =<< Annex.getGitRemotes
|
||||||
mapM (configRead autoinit) rs
|
mapM (configRead autoinit) rs
|
||||||
where
|
where
|
||||||
annexurl n = "remote." ++ n ++ ".annexurl"
|
annexurl n = "remote." ++ n ++ ".annexurl"
|
||||||
|
@ -104,8 +104,8 @@ gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remote
|
||||||
gitSetup Init mu _ c _ = do
|
gitSetup Init mu _ c _ = do
|
||||||
let location = fromMaybe (giveup "Specify location=url") $
|
let location = fromMaybe (giveup "Specify location=url") $
|
||||||
Url.parseURIRelaxed =<< M.lookup "location" c
|
Url.parseURIRelaxed =<< M.lookup "location" c
|
||||||
g <- Annex.gitRepo
|
rs <- Annex.getGitRemotes
|
||||||
u <- case filter (\r -> Git.location r == Git.Url location) (Git.remotes g) of
|
u <- case filter (\r -> Git.location r == Git.Url location) rs of
|
||||||
[r] -> getRepoUUID r
|
[r] -> getRepoUUID r
|
||||||
[] -> giveup "could not find existing git remote with specified location"
|
[] -> giveup "could not find existing git remote with specified location"
|
||||||
_ -> giveup "found multiple git remotes with specified location"
|
_ -> giveup "found multiple git remotes with specified location"
|
||||||
|
@ -263,10 +263,9 @@ tryGitConfigRead autoinit r
|
||||||
return r
|
return r
|
||||||
|
|
||||||
store = observe $ \r' -> do
|
store = observe $ \r' -> do
|
||||||
g <- gitRepo
|
l <- Annex.getGitRemotes
|
||||||
let l = Git.remotes g
|
let rs = exchange l r'
|
||||||
let g' = g { Git.remotes = exchange l r' }
|
Annex.changeState $ \s -> s { Annex.gitremotes = Just rs }
|
||||||
Annex.changeState $ \s -> s { Annex.repo = g' }
|
|
||||||
|
|
||||||
exchange [] _ = []
|
exchange [] _ = []
|
||||||
exchange (old:ls) new
|
exchange (old:ls) new
|
||||||
|
|
|
@ -17,6 +17,7 @@ import RemoteDaemon.Transport
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import qualified Git.Types as Git
|
import qualified Git.Types as Git
|
||||||
import qualified Git.CurrentRepo
|
import qualified Git.CurrentRepo
|
||||||
|
import qualified Git.Construct
|
||||||
import Utility.SimpleProtocol
|
import Utility.SimpleProtocol
|
||||||
import Utility.ThreadScheduler
|
import Utility.ThreadScheduler
|
||||||
import Config
|
import Config
|
||||||
|
@ -137,8 +138,9 @@ runController ichan ochan = do
|
||||||
-- Generates a map with a transport for each supported remote in the git repo,
|
-- Generates a map with a transport for each supported remote in the git repo,
|
||||||
-- except those that have annex.sync = false
|
-- except those that have annex.sync = false
|
||||||
genRemoteMap :: TransportHandle -> TChan Emitted -> IO RemoteMap
|
genRemoteMap :: TransportHandle -> TChan Emitted -> IO RemoteMap
|
||||||
genRemoteMap h@(TransportHandle (LocalRepo g) _) ochan =
|
genRemoteMap h@(TransportHandle (LocalRepo g) _) ochan = do
|
||||||
M.fromList . catMaybes <$> mapM gen (Git.remotes g)
|
rs <- Git.Construct.fromRemotes g
|
||||||
|
M.fromList . catMaybes <$> mapM gen rs
|
||||||
where
|
where
|
||||||
gen r = do
|
gen r = do
|
||||||
gc <- atomically $ extractRemoteGitConfig g (Git.repoDescribe r)
|
gc <- atomically $ extractRemoteGitConfig g (Git.repoDescribe r)
|
||||||
|
|
|
@ -0,0 +1,18 @@
|
||||||
|
[[!comment format=mdwn
|
||||||
|
username="joey"
|
||||||
|
subject="""comment 1"""
|
||||||
|
date="2018-01-09T17:02:41Z"
|
||||||
|
content="""
|
||||||
|
There are a couple of parts to this, so let's get this one out of the way
|
||||||
|
first: Tab completion etc should not be looking at remotes.
|
||||||
|
|
||||||
|
It seems that even `git annex --help` does for some reason; so does
|
||||||
|
stuff like `git annex examinekey`. So it's happening in a core code-path.
|
||||||
|
|
||||||
|
Ah, ok.. Git.Config.read uses Git.Construct.fromRemotes,
|
||||||
|
which uses Git.Construct.fromAbsPath, which stats
|
||||||
|
the remote directory to handle ".git" canonicalization.
|
||||||
|
|
||||||
|
Fixed this part of it; now only when the remoteList is built does it
|
||||||
|
stat remotes.
|
||||||
|
"""]]
|
|
@ -0,0 +1,39 @@
|
||||||
|
[[!comment format=mdwn
|
||||||
|
username="joey"
|
||||||
|
subject="""comment 2"""
|
||||||
|
date="2018-01-09T19:56:42Z"
|
||||||
|
content="""
|
||||||
|
With the above dealt with, the remaining problem is with commands
|
||||||
|
like `git annex whereis` or `git annex info`, which don't really
|
||||||
|
any on any remote, but still need to examine the remotes as part of
|
||||||
|
building the remoteList.
|
||||||
|
|
||||||
|
git-annex supports remotes that point to a mount point that might have
|
||||||
|
different drives mounted at it at different times. So, it needs to
|
||||||
|
check the git config of the remote each time, to see what repository is
|
||||||
|
currently there.
|
||||||
|
|
||||||
|
Even commands like "whereis" and "info" have output that depends on
|
||||||
|
what repository a remote is currently pointing to. In some cases,
|
||||||
|
"whereis" might not output anything that depends on a given remote,
|
||||||
|
so in theory it could avoid looking at the config of that remote.
|
||||||
|
And a command like "git annex copy --to origin" doesn't really
|
||||||
|
need to look at the configs of any other remotes.
|
||||||
|
|
||||||
|
But to avoid unncessarily checking the git configs of remotes that a
|
||||||
|
command does not use would need each use of the current remoteList
|
||||||
|
to be replaced with something else that does the minimal needed work,
|
||||||
|
instead of building the whole remoteList. I think this would be quite
|
||||||
|
complicated.
|
||||||
|
|
||||||
|
And, I don't know that it would address the bug report adequequately, even
|
||||||
|
if it were done. Running `git annex info` would
|
||||||
|
still block waiting for the automount; `git annex whereis` would
|
||||||
|
only *sometimes* block, depending on where content is.
|
||||||
|
|
||||||
|
So instead of that approach, perhaps a config setting will do?
|
||||||
|
A per-remote config that tells git-annex that only one repository
|
||||||
|
should ever be mounted at its location. That would make git-annex
|
||||||
|
avoid checking the git config of that remote each time, except
|
||||||
|
when it's actually storing/dropping content on it.
|
||||||
|
"""]]
|
Loading…
Reference in a new issue