almost able to get files from remotes now!
This commit is contained in:
parent
77055f5ff8
commit
e28ff5bdaf
6 changed files with 116 additions and 48 deletions
30
Annex.hs
30
Annex.hs
|
@ -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"
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
14
GitRepo.hs
14
GitRepo.hs
|
@ -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"
|
||||||
|
|
|
@ -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
50
Remotes.hs
Normal 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
31
UUID.hs
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue