diff options
| -rw-r--r-- | Annex.hs | 30 | ||||
| -rw-r--r-- | BackendFile.hs | 36 | ||||
| -rw-r--r-- | GitRepo.hs | 14 | ||||
| -rw-r--r-- | LocationLog.hs | 3 | ||||
| -rw-r--r-- | Remotes.hs | 50 | ||||
| -rw-r--r-- | UUID.hs | 31 |
6 files changed, 116 insertions, 48 deletions
@@ -9,7 +9,6 @@ module Annex ( annexWantFile, annexDropFile, annexPushRepo, - annexRemotes, annexPullRepo ) where @@ -161,37 +160,10 @@ gitSetup repo = do {- Updates the LocationLog when a key's presence changes. -} logStatus state key status = do - f <- logChange (repo state) key (getUUID (repo state)) status + f <- logChange (repo state) key (getUUID state (repo state)) status gitRun (repo state) ["add", f] gitRun (repo state) ["commit", "-m", "git-annex log update", f] {- Checks if a given key is currently present in the annexLocation -} inAnnex :: State -> Backend -> Key -> IO Bool inAnnex state backend key = doesFileExist $ annexLocation state backend key - -{- Ordered list of remotes for the annex. -} -annexRemotes :: State -> [GitRepo] -annexRemotes state = reposByCost state $ gitConfigRemotes (repo state) - -{- Orders a list of git repos by cost. -} -reposByCost :: State -> [GitRepo] -> [GitRepo] -reposByCost state l = - fst $ unzip $ sortBy (\(r1, c1) (r2, c2) -> compare c1 c2) $ costpairs l - where - costpairs l = map (\r -> (r, repoCost state r)) l - -{- Calculates cost for a repo. - - - - The default cost is 100 for local repositories, and 200 for remote - - repositories; it can also be configured by remote.<name>.annex-cost - -} -repoCost :: State -> GitRepo -> Int -repoCost state r = - if ((length $ config state r) > 0) - then read $ config state r - else if (gitRepoIsLocal r) - then 100 - else 200 - where - config state r = gitConfig (repo state) (configkey r) "" - configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost" diff --git a/BackendFile.hs b/BackendFile.hs index 15b23536b..d4d137e53 100644 --- a/BackendFile.hs +++ b/BackendFile.hs @@ -4,12 +4,16 @@ module BackendFile (backend) where import Types +import LocationLog +import Locations +import Remotes +import GitRepo backend = Backend { name = "file", getKey = keyValue, storeFileKey = dummyStore, - retrieveKeyFile = copyFromOtherRepo, + retrieveKeyFile = copyKeyFile, removeKey = dummyRemove } @@ -27,12 +31,26 @@ dummyStore state file key = return True dummyRemove :: State -> Key -> IO Bool dummyRemove state url = return False -{- Try to find a copy of the file in one of the other repos, +{- Try to find a copy of the file in one of the remotes, - and copy it over to this one. -} -copyFromOtherRepo :: State -> Key -> FilePath -> IO (Bool) -copyFromOtherRepo state key file = - -- 1. get ordered list of remotes (local repos, then remote repos) - -- 2. read locationlog for file - -- 3. filter remotes list to ones that have file - -- 4. attempt to transfer from each remote until success - error "copyFromOtherRepo unimplemented" -- TODO +copyKeyFile :: State -> Key -> FilePath -> IO (Bool) +copyKeyFile state key file = do + remotes <- remotesWithKey state key + if (0 == length remotes) + then error $ "no known remotes have: " ++ (keyFile key) ++ "\n" ++ + "(Perhaps you need to git remote add a repository?)" + 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 + ok <- copyFromRemote r key file + if (ok) + then return True + else trycopy full rs + +{- Tries to copy a file from a remote. -} +copyFromRemote :: GitRepo -> Key -> FilePath -> IO (Bool) +copyFromRemote r key file = do + return False -- TODO diff --git a/GitRepo.hs b/GitRepo.hs index 06e244d6b..e1f086b69 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -13,6 +13,7 @@ module GitRepo ( gitRepoIsLocal, gitRepoIsRemote, gitConfigRemotes, + gitRepoDescribe, gitWorkTree, gitDir, gitRelative, @@ -74,8 +75,13 @@ gitRepoFromUrl url = } where path url = uriPath $ fromJust $ parseURI url -{- User-visible description of a git repo by path or url -} -describe repo = if (gitRepoIsLocal repo) then top repo else url repo +{- User-visible description of a git repo. -} +gitRepoDescribe repo = + if (isJust $ remoteName repo) + then fromJust $ remoteName repo + else if (gitRepoIsLocal repo) + then top repo + else url repo {- Returns the name of the remote that corresponds to the repo, if - it is a remote. Otherwise, "" -} @@ -93,13 +99,13 @@ gitRepoIsRemote repo = not $ gitRepoIsLocal repo assertlocal repo action = if (gitRepoIsLocal repo) then action - else error $ "acting on remote git repo " ++ (describe repo) ++ + else error $ "acting on remote git repo " ++ (gitRepoDescribe repo) ++ " not supported" bare :: GitRepo -> Bool bare repo = if (member b (config repo)) then ("true" == fromJust (Map.lookup b (config repo))) - else error $ "it is not known if git repo " ++ (describe repo) ++ + else error $ "it is not known if git repo " ++ (gitRepoDescribe repo) ++ " is a bare repository; config not read" where b = "core.bare" diff --git a/LocationLog.hs b/LocationLog.hs index 2eab4815e..28ac46b90 100644 --- a/LocationLog.hs +++ b/LocationLog.hs @@ -18,7 +18,8 @@ module LocationLog ( LogStatus(..), - logChange + logChange, + keyLocations ) where import Data.Time.Clock.POSIX diff --git a/Remotes.hs b/Remotes.hs new file mode 100644 index 000000000..ae709a3c2 --- /dev/null +++ b/Remotes.hs @@ -0,0 +1,50 @@ +{- git-annex remote repositories -} + +module Remotes ( + remotesList, + remotesWithKey +) where + +import Types +import GitRepo +import LocationLog +import Data.String.Utils +import UUID +import List + +{- Human visible list of remotes. -} +remotesList :: [GitRepo] -> String +remotesList remotes = join " " $ map gitRepoDescribe remotes + +{- Cost ordered list of remotes that the LocationLog indicate may have a key. -} +remotesWithKey :: State -> Key -> IO [GitRepo] +remotesWithKey state key = do + uuids <- keyLocations (repo state) key + return $ reposByUUID state (remotesByCost state) uuids + +{- Cost Ordered list of remotes. -} +remotesByCost :: State -> [GitRepo] +remotesByCost state = reposByCost state $ gitConfigRemotes (repo state) + +{- Orders a list of git repos by cost. -} +reposByCost :: State -> [GitRepo] -> [GitRepo] +reposByCost state l = + fst $ unzip $ sortBy (\(r1, c1) (r2, c2) -> compare c1 c2) $ costpairs l + where + costpairs l = map (\r -> (r, repoCost state r)) l + +{- Calculates cost for a repo. + - + - The default cost is 100 for local repositories, and 200 for remote + - repositories; it can also be configured by remote.<name>.annex-cost + -} +repoCost :: State -> GitRepo -> Int +repoCost state r = + if ((length $ config state r) > 0) + then read $ config state r + else if (gitRepoIsLocal r) + then 100 + else 200 + where + config state r = gitConfig (repo state) (configkey r) "" + configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost" @@ -9,12 +9,16 @@ module UUID ( UUID, getUUID, prepUUID, - genUUID + genUUID, + reposByUUID ) where +import Maybe +import List import System.Cmd.Utils import System.IO import GitRepo +import Types type UUID = String @@ -26,17 +30,34 @@ genUUID :: IO UUID genUUID = do pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h -{- Looks up a repo's UUID -} -getUUID :: GitRepo -> UUID -getUUID repo = gitConfig repo "annex.uuid" "" +{- Looks up a repo's UUID. May return "" if none is known. + - + - UUIDs of remotes are cached in git config, using keys named + - remote.<name>.annex-uuid + - + - -} +getUUID :: State -> GitRepo -> UUID +getUUID s r = + if ("" /= getUUID' r) + then getUUID' r + else cached s r + where + cached s r = gitConfig (repo s) (configkey r) "" + configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-uuid" +getUUID' r = gitConfig r "annex.uuid" "" {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: GitRepo -> IO GitRepo prepUUID repo = - if ("" == getUUID repo) + if ("" == getUUID' repo) then do uuid <- genUUID gitRun repo ["config", configkey, uuid] -- return new repo with updated config gitConfigRead repo else return repo + +{- Filters a list of repos to ones that have listed UUIDs. -} +reposByUUID :: State -> [GitRepo] -> [UUID] -> [GitRepo] +reposByUUID state repos uuids = + filter (\r -> isJust $ elemIndex (getUUID state r) uuids) repos |