reorg
This commit is contained in:
parent
ca60731e1c
commit
533419147c
1 changed files with 39 additions and 38 deletions
77
Remotes.hs
77
Remotes.hs
|
@ -43,7 +43,42 @@ import RsyncFile
|
||||||
list :: [Git.Repo] -> String
|
list :: [Git.Repo] -> String
|
||||||
list remotes = join ", " $ map Git.repoDescribe remotes
|
list remotes = join ", " $ map Git.repoDescribe remotes
|
||||||
|
|
||||||
{- Reads the configs of remotes.
|
{- The git configs for the git repo's remotes is not read on startup
|
||||||
|
- because reading it may be expensive. This function tries to read the
|
||||||
|
- config for a specified remote, and updates state. If successful, it
|
||||||
|
- returns the updated git repo. -}
|
||||||
|
tryGitConfigRead :: Git.Repo -> Annex (Either Git.Repo Git.Repo)
|
||||||
|
tryGitConfigRead r
|
||||||
|
| not $ Map.null $ Git.configMap r = return $ Right r -- already read
|
||||||
|
| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
|
||||||
|
| Git.repoIsUrl r = return $ Left r
|
||||||
|
| otherwise = store $ safely $ Git.configRead r
|
||||||
|
where
|
||||||
|
-- Reading config can fail due to IO error or
|
||||||
|
-- for other reasons; catch all possible exceptions.
|
||||||
|
safely a = do
|
||||||
|
result <- liftIO (try (a)::IO (Either SomeException Git.Repo))
|
||||||
|
case result of
|
||||||
|
Left _ -> return r
|
||||||
|
Right r' -> return r'
|
||||||
|
pipedconfig cmd params = safely $
|
||||||
|
pOpen ReadFromPipe cmd params $
|
||||||
|
Git.hConfigRead r
|
||||||
|
store a = do
|
||||||
|
r' <- a
|
||||||
|
g <- Annex.gitRepo
|
||||||
|
let l = Git.remotes g
|
||||||
|
let g' = Git.remotesAdd g $ exchange l r'
|
||||||
|
Annex.gitRepoChange g'
|
||||||
|
return $ Right r'
|
||||||
|
exchange [] _ = []
|
||||||
|
exchange (old:ls) new =
|
||||||
|
if Git.repoRemoteName old == Git.repoRemoteName new
|
||||||
|
then new : exchange ls new
|
||||||
|
else old : exchange ls new
|
||||||
|
|
||||||
|
|
||||||
|
{- Reads the configs of all remotes.
|
||||||
-
|
-
|
||||||
- This has to be called before things that rely on eg, the UUID of
|
- This has to be called before things that rely on eg, the UUID of
|
||||||
- remotes. Most such things will take care of running this themselves.
|
- remotes. Most such things will take care of running this themselves.
|
||||||
|
@ -55,8 +90,8 @@ list remotes = join ", " $ map Git.repoDescribe remotes
|
||||||
- the config of an URL remote is only read when there is no
|
- the config of an URL remote is only read when there is no
|
||||||
- cached UUID value.
|
- cached UUID value.
|
||||||
- -}
|
- -}
|
||||||
readconfigs :: Annex ()
|
readConfigs :: Annex ()
|
||||||
readconfigs = do
|
readConfigs = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
remotesread <- Annex.flagIsSet "remotesread"
|
remotesread <- Annex.flagIsSet "remotesread"
|
||||||
unless remotesread $ do
|
unless remotesread $ do
|
||||||
|
@ -87,7 +122,7 @@ readconfigs = do
|
||||||
-}
|
-}
|
||||||
keyPossibilities :: Key -> Annex ([Git.Repo], [Git.Repo], [UUID])
|
keyPossibilities :: Key -> Annex ([Git.Repo], [Git.Repo], [UUID])
|
||||||
keyPossibilities key = do
|
keyPossibilities key = do
|
||||||
readconfigs
|
readConfigs
|
||||||
|
|
||||||
allremotes <- remotesByCost
|
allremotes <- remotesByCost
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
|
@ -201,40 +236,6 @@ byName name = do
|
||||||
"there is no git remote named \"" ++ name ++ "\""
|
"there is no git remote named \"" ++ name ++ "\""
|
||||||
return $ head match
|
return $ head match
|
||||||
|
|
||||||
{- The git configs for the git repo's remotes is not read on startup
|
|
||||||
- because reading it may be expensive. This function tries to read the
|
|
||||||
- config for a specified remote, and updates state. If successful, it
|
|
||||||
- returns the updated git repo. -}
|
|
||||||
tryGitConfigRead :: Git.Repo -> Annex (Either Git.Repo Git.Repo)
|
|
||||||
tryGitConfigRead r
|
|
||||||
| not $ Map.null $ Git.configMap r = return $ Right r -- already read
|
|
||||||
| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
|
|
||||||
| Git.repoIsUrl r = return $ Left r
|
|
||||||
| otherwise = store $ safely $ Git.configRead r
|
|
||||||
where
|
|
||||||
-- Reading config can fail due to IO error or
|
|
||||||
-- for other reasons; catch all possible exceptions.
|
|
||||||
safely a = do
|
|
||||||
result <- liftIO (try (a)::IO (Either SomeException Git.Repo))
|
|
||||||
case result of
|
|
||||||
Left _ -> return r
|
|
||||||
Right r' -> return r'
|
|
||||||
pipedconfig cmd params = safely $
|
|
||||||
pOpen ReadFromPipe cmd params $
|
|
||||||
Git.hConfigRead r
|
|
||||||
store a = do
|
|
||||||
r' <- a
|
|
||||||
g <- Annex.gitRepo
|
|
||||||
let l = Git.remotes g
|
|
||||||
let g' = Git.remotesAdd g $ exchange l r'
|
|
||||||
Annex.gitRepoChange g'
|
|
||||||
return $ Right r'
|
|
||||||
exchange [] _ = []
|
|
||||||
exchange (old:ls) new =
|
|
||||||
if Git.repoRemoteName old == Git.repoRemoteName new
|
|
||||||
then new : exchange ls new
|
|
||||||
else old : exchange ls new
|
|
||||||
|
|
||||||
{- Tries to copy a key's content from a remote's annex to a file. -}
|
{- Tries to copy a key's content from a remote's annex to a file. -}
|
||||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||||
copyFromRemote r key file
|
copyFromRemote r key file
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue