implemented remotes config caching

BackendFile.hs

@@ -43,16 +43,20 @@ copyKeyFile key file = do
 	if (0 == length remotes)
 		then error $ "no known remotes have: " ++ (keyFile key) ++ "\n" ++
 			"(Perhaps you need to git remote add a repository?)"
-		else liftIO $ trycopy remotes remotes
+		else trycopy remotes remotes
 	where
 		trycopy full [] = error $ "unable to get: " ++ (keyFile key) ++ "\n" ++
 			"To get that file, need access to one of these remotes: " ++
 			(remotesList full)
 		trycopy full (r:rs) = do
-			result <- try (copyFromRemote r key file)::IO (Either SomeException ())
+			-- annexLocation needs the git config to have been
+			-- read for a remote, so do that now,
+			-- if it hasn't been already
+			r' <- remoteEnsureGitConfigRead r
+			result <- liftIO $ (try (copyFromRemote r' key file)::IO (Either SomeException ()))
         		case (result) of
 		                Left err -> do
-					hPutStrLn stderr (show err)
+					liftIO $ hPutStrLn stderr (show err)
 					trycopy full rs
 		                Right succ -> return True
 
@@ -61,19 +65,11 @@ copyFromRemote :: GitRepo -> Key -> FilePath -> IO ()
 copyFromRemote r key file = do
 	putStrLn $ "copy from " ++ (gitRepoDescribe r ) ++ " " ++ file
 
-	-- annexLocation needs the git config read for the remote first.
-	-- FIXME: Having this here means git-config is run repeatedly when
-	-- copying a series of files; need to use state monad to avoid
-	-- this.
-	r' <- gitConfigRead r
-
-	_ <- if (gitRepoIsLocal r')
-		then getlocal r'
-		else getremote r'
+	if (gitRepoIsLocal r)
+		then getlocal
+		else getremote
 	return ()
 	where
-		getlocal r = do
-			rawSystem "cp" ["-a", location r, file]
-		getremote r = do
-			error "get via network not yet implemented!"
-		location r = annexLocation r backend key
+		getlocal = rawSystem "cp" ["-a", location, file]
+		getremote = error "get via network not yet implemented!"
+		location = annexLocation r backend key

GitRepo.hs

@@ -12,15 +12,17 @@ module GitRepo (
 	gitRepoFromUrl,
 	gitRepoIsLocal,
 	gitRepoIsRemote,
-	gitConfigRemotes,
 	gitRepoDescribe,
 	gitWorkTree,
 	gitDir,
 	gitRelative,
 	gitConfig,
+	gitConfigMap,
 	gitConfigRead,
 	gitRun,
 	gitAttributes,
+	gitRepoRemotes,
+	gitRepoRemotesAdd,
 	gitRepoRemoteName
 ) where
 
@@ -46,12 +48,14 @@ data GitRepo =
 	LocalGitRepo {
 		top :: FilePath,
 		config :: Map String String,
+		remotes :: [GitRepo],
 		-- remoteName holds the name used for this repo in remotes
 		remoteName :: Maybe String 
 	} | RemoteGitRepo {
 		url :: String,
 		top :: FilePath,
 		config :: Map String String,
+		remotes :: [GitRepo],
 		remoteName :: Maybe String
 	} deriving (Show, Read, Eq)
 
@@ -61,6 +65,7 @@ gitRepoFromPath dir =
 	LocalGitRepo {
 		top = dir,
 		config = Map.empty,
+		remotes = [],
 		remoteName = Nothing
 	}
 
@@ -71,6 +76,7 @@ gitRepoFromUrl url =
 		url = url,
 		top = path url,
 		config = Map.empty,
+		remotes = [],
 		remoteName = Nothing
 	}
 	where path url = uriPath $ fromJust $ parseURI url
@@ -83,6 +89,15 @@ gitRepoDescribe repo =
 			then top repo
 			else url repo
 
+{- Returns the list of a repo's remotes. -}
+gitRepoRemotes :: GitRepo -> [GitRepo]
+gitRepoRemotes r = remotes r
+
+{- Constructs and returns an updated version of a repo with
+ - different remotes list. -}
+gitRepoRemotesAdd :: GitRepo -> [GitRepo] -> GitRepo
+gitRepoRemotesAdd repo rs = repo { remotes = rs }
+
 {- Returns the name of the remote that corresponds to the repo, if 
  - it is a remote. Otherwise, "" -}
 gitRepoRemoteName r = 
@@ -169,10 +184,24 @@ gitConfigRead repo = assertlocal repo $ do
            been already read. Instead, chdir to the repo. -}
 	cwd <- getCurrentDirectory
 	bracket_ (changeWorkingDirectory (top repo))
-		(\_ -> changeWorkingDirectory cwd) $ do
+		(\_ -> changeWorkingDirectory cwd) $
 			pOpen ReadFromPipe "git" ["config", "--list"] $ \h -> do
 				val <- hGetContentsStrict h
-				return repo { config = gitConfigParse val }
+				let r = repo { config = gitConfigParse val }
+				return r { remotes = gitConfigRemotes r }
+
+{- Calculates a list of a repo's configured remotes, by parsing its config. -}
+gitConfigRemotes :: GitRepo -> [GitRepo]
+gitConfigRemotes repo = map construct remotes
+	where
+		remotes = toList $ filter $ config repo
+		filter = filterWithKey (\k _ -> isremote k)
+		isremote k = (startswith "remote." k) && (endswith ".url" k)
+		remotename k = (split "." k) !! 1
+		construct (k,v) = (gen v) { remoteName = Just $ remotename k }
+		gen v = if (isURI v)
+			then gitRepoFromUrl v
+			else gitRepoFromPath v
 
 {- Parses git config --list output into a config map. -}
 gitConfigParse :: String -> Map.Map String String
@@ -189,18 +218,9 @@ gitConfig :: GitRepo -> String -> String -> String
 gitConfig repo key defaultValue = 
 	Map.findWithDefault defaultValue key (config repo)
 
-{- Returns a list of a repo's configured remotes. -}
-gitConfigRemotes :: GitRepo -> [GitRepo]
-gitConfigRemotes repo = map construct remotes
-	where
-		remotes = toList $ filter $ config repo
-		filter = filterWithKey (\k _ -> isremote k)
-		isremote k = (startswith "remote." k) && (endswith ".url" k)
-		remotename k = (split "." k) !! 1
-		construct (k,v) = (gen v) { remoteName = Just $ remotename k }
-		gen v = if (isURI v)
-			then gitRepoFromUrl v
-			else gitRepoFromPath v
+{- Access to raw config Map -}
+gitConfigMap :: GitRepo -> Map String String
+gitConfigMap repo = config repo
 
 {- Finds the current git repository, which may be in a parent directory. -}
 gitRepoFromCwd :: IO GitRepo

Remotes.hs

@@ -2,10 +2,12 @@
 
 module Remotes (
 	remotesList,
-	remotesWithKey
+	remotesWithKey,
+	remoteEnsureGitConfigRead
 ) where
 
 import Control.Monad.State (liftIO)
+import qualified Data.Map as Map
 import Types
 import GitRepo
 import LocationLog
@@ -29,7 +31,7 @@ remotesWithKey key = do
 remotesByCost :: Annex [GitRepo]
 remotesByCost = do
 	g <- gitAnnex
-	reposByCost $ gitConfigRemotes g
+	reposByCost $ gitRepoRemotes g
 
 {- Orders a list of git repos by cost. -}
 reposByCost :: [GitRepo] -> Annex [GitRepo]
@@ -58,3 +60,25 @@ repoCost r = do
 	where
 		config g r = gitConfig g (configkey r) ""
 		configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost"
+
+{- The git configs for the git repo's remotes is not read on startup
+ - because reading it may be expensive. This function ensures that it is
+ - read for a specified remote, and updates state. It returns the
+ - updated git repo also. -}
+remoteEnsureGitConfigRead :: GitRepo -> Annex GitRepo
+remoteEnsureGitConfigRead r = do
+	if (Map.null $ gitConfigMap r)
+		then do
+			r' <- liftIO $ gitConfigRead r
+			g <- gitAnnex
+			let l = gitRepoRemotes g
+			let g' = gitRepoRemotesAdd g $ exchange l r'
+			gitAnnexChange g'
+			return r'
+		else return r
+	where 
+		exchange [] new = []
+		exchange (old:ls) new =
+			if ((gitRepoRemoteName old) == (gitRepoRemoteName new))
+				then new:(exchange ls new)
+				else old:(exchange ls new)