summaryrefslogtreecommitdiff
path: root/Backend
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2010-10-17 11:47:36 -0400
committerGravatar Joey Hess <joey@kitenet.net>2010-10-17 11:47:36 -0400
commitb471822cfe4476995f539c6e7e7da7f7bf2b5e02 (patch)
tree31963b299051850ee0514dfec9a655e4a326c503 /Backend
parent6bfa534aa4d7552c4ccfdb9523b55da19fac8883 (diff)
move supportedBackends list into annex monad
This was necessary so the File backend could import Backend w/o a cycle. Moved code that checks whether enough backends have a file into File backend.
Diffstat (limited to 'Backend')
-rw-r--r--Backend/File.hs60
1 files changed, 55 insertions, 5 deletions
diff --git a/Backend/File.hs b/Backend/File.hs
index f5237f721..591ff3db4 100644
--- a/Backend/File.hs
+++ b/Backend/File.hs
@@ -25,13 +25,14 @@ import Utility
import Core
import qualified Annex
import UUID
+import qualified Backend
backend = Backend {
name = mustProvide,
getKey = mustProvide,
storeFileKey = dummyStore,
retrieveKeyFile = copyKeyFile,
- removeKey = dummyRemove,
+ removeKey = checkRemoveKey,
hasKey = checkKeyFile
}
@@ -41,10 +42,6 @@ mustProvide = error "must provide this field"
dummyStore :: FilePath -> Key -> Annex (Bool)
dummyStore file key = return True
-{- Allow keys to be removed. -}
-dummyRemove :: Key -> Annex Bool
-dummyRemove url = return True
-
{- Just check if the .git/annex/ file for the key exists. -}
checkKeyFile :: Key -> Annex Bool
checkKeyFile k = inAnnex k
@@ -102,3 +99,56 @@ copyFromRemote r key file = do
else error "cp failed"
getremote = error "get via network not yet implemented!"
location = annexLocation r key
+
+{- Checks remotes to verify that enough copies of a key exist to allow
+ - for a key to be safely removed (with no data loss), and fails with an
+ - error if not. -}
+checkRemoveKey :: Key -> Annex (Bool)
+checkRemoveKey key = do
+ force <- Annex.flagIsSet Force
+ if (force)
+ then return True
+ else do
+ g <- Annex.gitRepo
+ let numcopies = read $ Git.configGet g config "1"
+ remotes <- Remotes.withKey key
+ if (numcopies > length remotes)
+ then retNotEnoughCopiesKnown remotes numcopies
+ else findcopies numcopies remotes []
+ where
+ failMsg w = do
+ liftIO $ hPutStrLn stderr $ "git-annex: " ++ w
+ return False -- failure, not enough copies found
+ findcopies 0 _ _ = return True -- success, enough copies found
+ findcopies _ [] bad = notEnoughCopiesSeen bad
+ findcopies n (r:rs) bad = do
+ all <- Annex.supportedBackends
+ result <- liftIO $ ((try $ remoteHasKey r all)::IO (Either SomeException Bool))
+ case (result) of
+ Right True -> findcopies (n-1) rs bad
+ Right False -> findcopies n rs bad
+ Left _ -> findcopies n rs (r:bad)
+ remoteHasKey r all = do
+ -- To check if a remote has a key, construct a new
+ -- Annex monad and query its backend.
+ a <- Annex.new r all
+ (result, _) <- Annex.run a (Backend.hasKey key)
+ return result
+ notEnoughCopiesSeen bad = failMsg $
+ "I failed to find enough other copies of: " ++
+ (keyFile key) ++
+ (if (0 /= length bad) then listbad bad else "")
+ ++ unsafe
+ listbad bad = "\nI was unable to access these remotes: " ++
+ (Remotes.list bad)
+ retNotEnoughCopiesKnown remotes numcopies = failMsg $
+ "I only know about " ++ (show $ length remotes) ++
+ " out of " ++ (show numcopies) ++
+ " necessary copies of: " ++ (keyFile key) ++
+ unsafe
+ unsafe = "\n" ++
+ " -- According to the " ++ config ++
+ " setting, it is not safe to remove it!\n" ++
+ " (Use --force to override.)"
+
+ config = "annex.numcopies"