almost able to get files from remotes now!

This commit is contained in:
Joey Hess 2010-10-13 15:55:18 -04:00
parent 77055f5ff8
commit e28ff5bdaf
6 changed files with 116 additions and 48 deletions

View file

@ -9,7 +9,6 @@ module Annex (
annexWantFile, annexWantFile,
annexDropFile, annexDropFile,
annexPushRepo, annexPushRepo,
annexRemotes,
annexPullRepo annexPullRepo
) where ) where
@ -161,37 +160,10 @@ gitSetup repo = do
{- Updates the LocationLog when a key's presence changes. -} {- Updates the LocationLog when a key's presence changes. -}
logStatus state key status = do 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) ["add", f]
gitRun (repo state) ["commit", "-m", "git-annex log update", f] gitRun (repo state) ["commit", "-m", "git-annex log update", f]
{- Checks if a given key is currently present in the annexLocation -} {- Checks if a given key is currently present in the annexLocation -}
inAnnex :: State -> Backend -> Key -> IO Bool inAnnex :: State -> Backend -> Key -> IO Bool
inAnnex state backend key = doesFileExist $ annexLocation state backend key 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"

View file

@ -4,12 +4,16 @@
module BackendFile (backend) where module BackendFile (backend) where
import Types import Types
import LocationLog
import Locations
import Remotes
import GitRepo
backend = Backend { backend = Backend {
name = "file", name = "file",
getKey = keyValue, getKey = keyValue,
storeFileKey = dummyStore, storeFileKey = dummyStore,
retrieveKeyFile = copyFromOtherRepo, retrieveKeyFile = copyKeyFile,
removeKey = dummyRemove removeKey = dummyRemove
} }
@ -27,12 +31,26 @@ dummyStore state file key = return True
dummyRemove :: State -> Key -> IO Bool dummyRemove :: State -> Key -> IO Bool
dummyRemove state url = return False 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. -} - and copy it over to this one. -}
copyFromOtherRepo :: State -> Key -> FilePath -> IO (Bool) copyKeyFile :: State -> Key -> FilePath -> IO (Bool)
copyFromOtherRepo state key file = copyKeyFile state key file = do
-- 1. get ordered list of remotes (local repos, then remote repos) remotes <- remotesWithKey state key
-- 2. read locationlog for file if (0 == length remotes)
-- 3. filter remotes list to ones that have file then error $ "no known remotes have: " ++ (keyFile key) ++ "\n" ++
-- 4. attempt to transfer from each remote until success "(Perhaps you need to git remote add a repository?)"
error "copyFromOtherRepo unimplemented" -- TODO 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

View file

@ -13,6 +13,7 @@ module GitRepo (
gitRepoIsLocal, gitRepoIsLocal,
gitRepoIsRemote, gitRepoIsRemote,
gitConfigRemotes, gitConfigRemotes,
gitRepoDescribe,
gitWorkTree, gitWorkTree,
gitDir, gitDir,
gitRelative, gitRelative,
@ -74,8 +75,13 @@ gitRepoFromUrl url =
} }
where path url = uriPath $ fromJust $ parseURI url where path url = uriPath $ fromJust $ parseURI url
{- User-visible description of a git repo by path or url -} {- User-visible description of a git repo. -}
describe repo = if (gitRepoIsLocal repo) then top repo else url 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 {- Returns the name of the remote that corresponds to the repo, if
- it is a remote. Otherwise, "" -} - it is a remote. Otherwise, "" -}
@ -93,13 +99,13 @@ gitRepoIsRemote repo = not $ gitRepoIsLocal repo
assertlocal repo action = assertlocal repo action =
if (gitRepoIsLocal repo) if (gitRepoIsLocal repo)
then action then action
else error $ "acting on remote git repo " ++ (describe repo) ++ else error $ "acting on remote git repo " ++ (gitRepoDescribe repo) ++
" not supported" " not supported"
bare :: GitRepo -> Bool bare :: GitRepo -> Bool
bare repo = bare repo =
if (member b (config repo)) if (member b (config repo))
then ("true" == fromJust (Map.lookup 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" " is a bare repository; config not read"
where where
b = "core.bare" b = "core.bare"

View file

@ -18,7 +18,8 @@
module LocationLog ( module LocationLog (
LogStatus(..), LogStatus(..),
logChange logChange,
keyLocations
) where ) where
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX

50
Remotes.hs Normal file
View file

@ -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"

31
UUID.hs
View file

@ -9,12 +9,16 @@ module UUID (
UUID, UUID,
getUUID, getUUID,
prepUUID, prepUUID,
genUUID genUUID,
reposByUUID
) where ) where
import Maybe
import List
import System.Cmd.Utils import System.Cmd.Utils
import System.IO import System.IO
import GitRepo import GitRepo
import Types
type UUID = String type UUID = String
@ -26,17 +30,34 @@ genUUID :: IO UUID
genUUID = do genUUID = do
pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h
{- Looks up a repo's UUID -} {- Looks up a repo's UUID. May return "" if none is known.
getUUID :: GitRepo -> UUID -
getUUID repo = gitConfig repo "annex.uuid" "" - 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. -} {- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: GitRepo -> IO GitRepo prepUUID :: GitRepo -> IO GitRepo
prepUUID repo = prepUUID repo =
if ("" == getUUID repo) if ("" == getUUID' repo)
then do then do
uuid <- genUUID uuid <- genUUID
gitRun repo ["config", configkey, uuid] gitRun repo ["config", configkey, uuid]
-- return new repo with updated config -- return new repo with updated config
gitConfigRead repo gitConfigRead repo
else return 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