diff options
| -rw-r--r-- | BackendFile.hs | 30 | ||||
| -rw-r--r-- | GitRepo.hs | 50 | ||||
| -rw-r--r-- | Remotes.hs | 28 |
3 files changed, 74 insertions, 34 deletions
diff --git a/BackendFile.hs b/BackendFile.hs index 9b82a0b20..d16f3611b 100644 --- a/BackendFile.hs +++ b/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 diff --git a/GitRepo.hs b/GitRepo.hs index e1f086b69..d22218219 100644 --- a/GitRepo.hs +++ b/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 diff --git a/Remotes.hs b/Remotes.hs index 399291467..13b87982c 100644 --- a/Remotes.hs +++ b/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) |