reorg remote key presense checking code
Also, it now checks if a key is inAnnex, ie, cached in .git/annex, not if it is present in a remote. For the File Backend, these are equivilant, not so for other backends.
This commit is contained in:
parent
5a91543be3
commit
9dfbf40d1a
3 changed files with 40 additions and 32 deletions
|
@ -44,24 +44,15 @@ mustProvide = error "must provide this field"
|
||||||
dummyStore :: FilePath -> Key -> Annex (Bool)
|
dummyStore :: FilePath -> Key -> Annex (Bool)
|
||||||
dummyStore file key = return True
|
dummyStore file key = return True
|
||||||
|
|
||||||
{- Just check if the .git/annex/ file for the key exists.
|
{- Just check if the .git/annex/ file for the key exists. -}
|
||||||
-
|
|
||||||
- But, if running against a remote annex, need to use ssh to do it. -}
|
|
||||||
checkKeyFile :: Key -> Annex Bool
|
checkKeyFile :: Key -> Annex Bool
|
||||||
checkKeyFile k = do
|
checkKeyFile k = inAnnex k
|
||||||
g <- Annex.gitRepo
|
|
||||||
if (not $ Git.repoIsUrl g)
|
|
||||||
then inAnnex k
|
|
||||||
else do
|
|
||||||
showNote ("checking " ++ Git.repoDescribe g ++ "...")
|
|
||||||
liftIO $ boolSystem "ssh" [Git.urlHost g,
|
|
||||||
"test -e " ++ (shellEscape $ annexLocation g k)]
|
|
||||||
|
|
||||||
{- Try to find a copy of the file in one of the remotes,
|
{- 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. -}
|
||||||
copyKeyFile :: Key -> FilePath -> Annex (Bool)
|
copyKeyFile :: Key -> FilePath -> Annex (Bool)
|
||||||
copyKeyFile key file = do
|
copyKeyFile key file = do
|
||||||
remotes <- Remotes.withKey key
|
remotes <- Remotes.keyPossibilities key
|
||||||
if (null remotes)
|
if (null remotes)
|
||||||
then do
|
then do
|
||||||
showNote "not available"
|
showNote "not available"
|
||||||
|
@ -97,7 +88,6 @@ copyFromRemote r key file = do
|
||||||
getlocal = boolSystem "cp" ["-a", location, file]
|
getlocal = boolSystem "cp" ["-a", location, file]
|
||||||
getssh = do
|
getssh = do
|
||||||
liftIO $ putStrLn "" -- make way for scp progress bar
|
liftIO $ putStrLn "" -- make way for scp progress bar
|
||||||
-- TODO double-shell-quote path for scp
|
|
||||||
boolSystem "scp" [sshlocation, file]
|
boolSystem "scp" [sshlocation, file]
|
||||||
location = annexLocation r key
|
location = annexLocation r key
|
||||||
sshlocation = (Git.urlHost r) ++ ":" ++ location
|
sshlocation = (Git.urlHost r) ++ ":" ++ location
|
||||||
|
@ -112,7 +102,7 @@ checkRemoveKey key = do
|
||||||
then return True
|
then return True
|
||||||
else do
|
else do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
remotes <- Remotes.withKey key
|
remotes <- Remotes.keyPossibilities key
|
||||||
let numcopies = read $ Git.configGet g config "1"
|
let numcopies = read $ Git.configGet g config "1"
|
||||||
if (numcopies > length remotes)
|
if (numcopies > length remotes)
|
||||||
then notEnoughCopies numcopies (length remotes) []
|
then notEnoughCopies numcopies (length remotes) []
|
||||||
|
@ -124,18 +114,11 @@ checkRemoveKey key = do
|
||||||
then return True
|
then return True
|
||||||
else notEnoughCopies need have bad
|
else notEnoughCopies need have bad
|
||||||
findcopies need have (r:rs) bad = do
|
findcopies need have (r:rs) bad = do
|
||||||
all <- Annex.supportedBackends
|
haskey <- Remotes.inAnnex r key
|
||||||
result <- liftIO $ ((try $ remoteHasKey r all)::IO (Either SomeException Bool))
|
case (haskey) of
|
||||||
case (result) of
|
|
||||||
Right True -> findcopies need (have+1) rs bad
|
Right True -> findcopies need (have+1) rs bad
|
||||||
Right False -> findcopies need have rs bad
|
Right False -> findcopies need have rs bad
|
||||||
Left _ -> findcopies need have rs (r:bad)
|
Left _ -> findcopies need have rs (r:bad)
|
||||||
remoteHasKey remote all = do
|
|
||||||
-- To check if a remote has a key, construct a new
|
|
||||||
-- Annex monad and query its backend.
|
|
||||||
a <- Annex.new remote all
|
|
||||||
(result, _) <- Annex.run a (Backend.hasKey key)
|
|
||||||
return result
|
|
||||||
notEnoughCopies need have bad = do
|
notEnoughCopies need have bad = do
|
||||||
unsafe
|
unsafe
|
||||||
showLongNote $
|
showLongNote $
|
||||||
|
|
12
Core.hs
12
Core.hs
|
@ -62,11 +62,19 @@ gitAttributes repo = do
|
||||||
Git.run repo ["commit", "-m", "git-annex setup",
|
Git.run repo ["commit", "-m", "git-annex setup",
|
||||||
attributes]
|
attributes]
|
||||||
|
|
||||||
{- Checks if a given key is currently present in the annexLocation -}
|
{- Checks if a given key is currently present in the annexLocation.
|
||||||
|
-
|
||||||
|
- This can be run against a remote repository to check the key there. -}
|
||||||
inAnnex :: Key -> Annex Bool
|
inAnnex :: Key -> Annex Bool
|
||||||
inAnnex key = do
|
inAnnex key = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
liftIO $ doesFileExist $ annexLocation g key
|
if (not $ Git.repoIsUrl g)
|
||||||
|
then liftIO $ doesFileExist $ annexLocation g key
|
||||||
|
else do
|
||||||
|
showNote ("checking " ++ Git.repoDescribe g ++ "...")
|
||||||
|
liftIO $ boolSystem "ssh" [Git.urlHost g,
|
||||||
|
"test -e " ++
|
||||||
|
(shellEscape $ annexLocation g key)]
|
||||||
|
|
||||||
{- Calculates the relative path to use to link a file to a key. -}
|
{- Calculates the relative path to use to link a file to a key. -}
|
||||||
calcGitLink :: FilePath -> Key -> Annex FilePath
|
calcGitLink :: FilePath -> Key -> Annex FilePath
|
||||||
|
|
31
Remotes.hs
31
Remotes.hs
|
@ -2,8 +2,9 @@
|
||||||
|
|
||||||
module Remotes (
|
module Remotes (
|
||||||
list,
|
list,
|
||||||
withKey,
|
keyPossibilities,
|
||||||
tryGitConfigRead
|
tryGitConfigRead,
|
||||||
|
inAnnex
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
|
@ -18,18 +19,19 @@ import Maybe
|
||||||
import Types
|
import Types
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
import qualified Backend
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Locations
|
import Locations
|
||||||
import UUID
|
import UUID
|
||||||
import Core
|
import qualified Core
|
||||||
|
|
||||||
{- Human visible list of remotes. -}
|
{- Human visible list of remotes. -}
|
||||||
list :: [Git.Repo] -> String
|
list :: [Git.Repo] -> String
|
||||||
list remotes = join ", " $ map Git.repoDescribe remotes
|
list remotes = join ", " $ map Git.repoDescribe remotes
|
||||||
|
|
||||||
{- Cost ordered list of remotes that the LocationLog indicate may have a key. -}
|
{- Cost ordered list of remotes that the LocationLog indicate may have a key. -}
|
||||||
withKey :: Key -> Annex [Git.Repo]
|
keyPossibilities :: Key -> Annex [Git.Repo]
|
||||||
withKey key = do
|
keyPossibilities key = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
uuids <- liftIO $ keyLocations g key
|
uuids <- liftIO $ keyLocations g key
|
||||||
allremotes <- remotesByCost
|
allremotes <- remotesByCost
|
||||||
|
@ -50,20 +52,35 @@ withKey key = do
|
||||||
let expensive = filter Git.repoIsUrl allremotes
|
let expensive = filter Git.repoIsUrl allremotes
|
||||||
doexpensive <- filterM cachedUUID expensive
|
doexpensive <- filterM cachedUUID expensive
|
||||||
if (not $ null doexpensive)
|
if (not $ null doexpensive)
|
||||||
then showNote $ "getting UUIDs for " ++ (list doexpensive) ++ "..."
|
then Core.showNote $ "getting UUIDs for " ++ (list doexpensive) ++ "..."
|
||||||
else return ()
|
else return ()
|
||||||
let todo = cheap ++ doexpensive
|
let todo = cheap ++ doexpensive
|
||||||
if (not $ null todo)
|
if (not $ null todo)
|
||||||
then do
|
then do
|
||||||
e <- mapM tryGitConfigRead todo
|
e <- mapM tryGitConfigRead todo
|
||||||
Annex.flagChange "remotesread" $ FlagBool True
|
Annex.flagChange "remotesread" $ FlagBool True
|
||||||
withKey key
|
keyPossibilities key
|
||||||
else reposByUUID allremotes uuids
|
else reposByUUID allremotes uuids
|
||||||
where
|
where
|
||||||
cachedUUID r = do
|
cachedUUID r = do
|
||||||
u <- getUUID r
|
u <- getUUID r
|
||||||
return $ null u
|
return $ null u
|
||||||
|
|
||||||
|
{- Checks if a given remote has the content for a key inAnnex.
|
||||||
|
-
|
||||||
|
- This is done by constructing a new Annex monad using the remote.
|
||||||
|
-
|
||||||
|
- If the remote cannot be accessed, returns a Left error.
|
||||||
|
-}
|
||||||
|
inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool)
|
||||||
|
inAnnex remote key = do
|
||||||
|
a <- liftIO $ Annex.new remote []
|
||||||
|
liftIO $ ((try $ check a)::IO (Either IOException Bool))
|
||||||
|
where
|
||||||
|
check a = do
|
||||||
|
(result, _) <- Annex.run a (Core.inAnnex key)
|
||||||
|
return result
|
||||||
|
|
||||||
{- Cost Ordered list of remotes. -}
|
{- Cost Ordered list of remotes. -}
|
||||||
remotesByCost :: Annex [Git.Repo]
|
remotesByCost :: Annex [Git.Repo]
|
||||||
remotesByCost = do
|
remotesByCost = do
|
||||||
|
|
Loading…
Reference in a new issue