diff options
author | 2010-10-14 13:11:42 -0400 | |
---|---|---|
committer | 2010-10-14 13:11:42 -0400 | |
commit | 8df3e2aa0227e426ade1d92f430e02e31bb97ad9 (patch) | |
tree | fee5e2bad45855397b26b982516155e062e02380 | |
parent | 282d9853682f457cc6dc8b095b230bd892f0a5f3 (diff) |
query remotes for uuids
(not cached yet)
-rw-r--r-- | Backend/File.hs | 21 | ||||
-rw-r--r-- | Remotes.hs | 52 |
2 files changed, 49 insertions, 24 deletions
diff --git a/Backend/File.hs b/Backend/File.hs index 107ef3851..78e1f5563 100644 --- a/Backend/File.hs +++ b/Backend/File.hs @@ -49,13 +49,16 @@ copyKeyFile key file = do -- annexLocation needs the git config to have been -- read for a remote, so do that now, -- if it hasn't been already - r' <- Remotes.ensureGitConfigRead r - result <- liftIO $ (try (copyFromRemote r' key file)::IO (Either SomeException ())) - case (result) of - Left err -> do - liftIO $ hPutStrLn stderr (show err) - trycopy full rs - Right succ -> return True + result <- Remotes.tryGitConfigRead r + case (result) of + Nothing -> trycopy full rs + Just r' -> do + result <- liftIO $ (try (copyFromRemote r' key file)::IO (Either SomeException ())) + case (result) of + Left err -> do + liftIO $ hPutStrLn stderr (show err) + trycopy full rs + Right succ -> return True {- Tries to copy a file from a remote, exception on error. -} copyFromRemote :: Git.Repo -> Key -> FilePath -> IO () @@ -67,6 +70,8 @@ copyFromRemote r key file = do else getremote return () where - getlocal = rawSystem "cp" ["-a", location, file] + getlocal = do + rawSystem "cp" ["-a", location, file] + putStrLn "cp done" getremote = error "get via network not yet implemented!" location = annexLocation r backend key diff --git a/Remotes.hs b/Remotes.hs index 1802ff28e..ecb0d96e3 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -3,19 +3,21 @@ module Remotes ( list, withKey, - ensureGitConfigRead + tryGitConfigRead ) where import Control.Monad.State (liftIO) +import IO import qualified Data.Map as Map import Data.String.Utils +import List +import Maybe import Types import qualified GitRepo as Git import qualified Annex import LocationLog import Locations import UUID -import List {- Human visible list of remotes. -} list :: [Git.Repo] -> String @@ -27,12 +29,25 @@ withKey key = do g <- Annex.gitRepo uuids <- liftIO $ keyLocations g key allremotes <- remotesByCost + -- this only uses cached data, so may not find new remotes remotes <- reposByUUID allremotes uuids if (0 == length remotes) - then error $ "no configured git remotes have: " ++ (keyFile key) ++ "\n" ++ + then tryharder allremotes uuids + else return remotes + where + tryharder allremotes uuids = do + -- more expensive; check each remote's config + mayberemotes <- mapM tryGitConfigRead allremotes + let allremotes' = catMaybes mayberemotes + remotes' <- reposByUUID allremotes' uuids + if (0 == length remotes') + then err uuids + else return remotes' + err uuids = + error $ "no available git remotes have: " ++ + (keyFile key) ++ "\n" ++ "It has been seen before in these repositories:\n" ++ prettyPrintUUIDs uuids - else return remotes {- Cost Ordered list of remotes. -} remotesByCost :: Annex [Git.Repo] @@ -69,20 +84,25 @@ repoCost r = do configkey r = "remote." ++ (Git.repoRemoteName 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. -} -ensureGitConfigRead :: Git.Repo -> Annex Git.Repo -ensureGitConfigRead r = do + - 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 (Maybe Git.Repo) +tryGitConfigRead r = do if (Map.null $ Git.configMap r) then do - r' <- liftIO $ Git.configRead r - g <- Annex.gitRepo - let l = Git.remotes g - let g' = Git.remotesAdd g $ exchange l r' - Annex.gitRepoChange g' - return r' - else return r + liftIO $ putStrLn $ "read config for " ++ (show r) + result <- liftIO $ try (Git.configRead r) + case (result) of + Left err -> return Nothing + Right r' -> do + g <- Annex.gitRepo + let l = Git.remotes g + let g' = Git.remotesAdd g $ + exchange l r' + Annex.gitRepoChange g' + return $ Just r' + else return $ Just r where exchange [] new = [] exchange (old:ls) new = |