diff options
| -rw-r--r-- | Backend.hs | 15 | ||||
| -rw-r--r-- | Backend/File.hs | 13 | ||||
| -rw-r--r-- | Commands.hs | 41 | ||||
| -rw-r--r-- | Remotes.hs | 10 | ||||
| -rw-r--r-- | TODO | 3 |
5 files changed, 71 insertions, 11 deletions
diff --git a/Backend.hs b/Backend.hs index 7a8178a8e..47e42b822 100644 --- a/Backend.hs +++ b/Backend.hs @@ -15,8 +15,9 @@ module Backend ( storeFileKey, - removeKey, retrieveKeyFile, + removeKey, + hasKey, lookupFile ) where @@ -77,6 +78,18 @@ retrieveKeyFile backend key dest = (B.retrieveKeyFile backend) key dest removeKey :: Backend -> Key -> Annex Bool removeKey backend key = (B.removeKey backend) key +{- Checks if any backend has a key. -} +hasKey :: Key -> Annex Bool +hasKey key = do + b <- backendList + hasKey' b key +hasKey' [] key = return False +hasKey' (b:bs) key = do + has <- (B.hasKey b) key + if (has) + then return True + else hasKey' bs key + {- Looks up the key and backend corresponding to an annexed file, - by examining what the file symlinks to. -} lookupFile :: FilePath -> IO (Maybe (Key, Backend)) diff --git a/Backend/File.hs b/Backend/File.hs index 893850a69..def2f3091 100644 --- a/Backend/File.hs +++ b/Backend/File.hs @@ -15,6 +15,8 @@ import qualified Remotes import qualified GitRepo as Git import Utility import Core +import qualified Annex +import UUID backend = Backend { name = "file", @@ -49,6 +51,9 @@ checkKeyFile k = inAnnex backend k copyKeyFile :: Key -> FilePath -> Annex (Bool) copyKeyFile key file = do remotes <- Remotes.withKey key + if (0 == length remotes) + then cantfind + else return () trycopy remotes remotes where trycopy full [] = error $ "unable to get: " ++ (keyFile key) ++ "\n" ++ @@ -68,6 +73,14 @@ copyKeyFile key file = do liftIO $ hPutStrLn stderr (show err) trycopy full rs Right succ -> return True + cantfind = do + g <- Annex.gitRepo + uuids <- liftIO $ keyLocations g key + error $ "no available git remotes have: " ++ + (keyFile key) ++ (uuidlist uuids) + uuidlist [] = "" + uuidlist uuids = "\nIt has been seen before in these repositories:\n" ++ + prettyPrintUUIDs uuids {- Tries to copy a file from a remote, exception on error. -} copyFromRemote :: Git.Repo -> Key -> FilePath -> IO () diff --git a/Commands.hs b/Commands.hs index 730663b0d..6128b76aa 100644 --- a/Commands.hs +++ b/Commands.hs @@ -8,6 +8,7 @@ import System.Posix.Files import System.Directory import Data.String.Utils import List +import IO import qualified GitRepo as Git import qualified Annex import Utility @@ -18,6 +19,7 @@ import UUID import LocationLog import Types import Core +import qualified Remotes options :: [OptDescr (String -> Annex ())] options = @@ -138,7 +140,7 @@ wantCmd file = do error "not implemented" -- TODO {- Indicates a file is not wanted. -} dropCmd :: FilePath -> Annex () dropCmd file = notinBackend file err $ \(key, backend) -> do - -- TODO only remove if enough copies are present elsewhere + requireEnoughCopies key success <- Backend.removeKey backend key if (success) then do @@ -181,3 +183,40 @@ inBackend file yes no = do Just v -> yes v Nothing -> no notinBackend file yes no = inBackend file no yes + +{- 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. -} +requireEnoughCopies :: Key -> Annex () +requireEnoughCopies key = do + g <- Annex.gitRepo + let numcopies = read $ Git.configGet g config "1" + remotes <- Remotes.withKey key + if (numcopies > length remotes) + then error $ "I only know about " ++ (show $ length remotes) ++ + " out of " ++ (show numcopies) ++ + " necessary copies of: " ++ (keyFile key) ++ + unsafe + else findcopies numcopies remotes [] + where + findcopies 0 _ _ = return () -- success, enough copies found + findcopies _ [] bad = die bad + findcopies n (r:rs) bad = do + result <- liftIO $ try $ haskey r + case (result) of + Right True -> findcopies (n-1) rs bad + Left _ -> findcopies n rs (r:bad) + haskey r = do + -- To check if a remote has a key, construct a new + -- Annex monad and query its backend. + a <- Annex.new r + (result, _) <- Annex.run a (Backend.hasKey key) + return result + die bad = + error $ "I failed to find enough other copies of: " ++ + (keyFile key) ++ "\n" ++ + "I was unable to access these remotes: " ++ + (Remotes.list bad) ++ unsafe + unsafe = "\n -- According to the " ++ config ++ + " setting, it is not safe to remove it!" + config = "annex.numcopies" diff --git a/Remotes.hs b/Remotes.hs index f20d51ab3..2fffcffa7 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -40,15 +40,7 @@ withKey key = do mayberemotes <- mapM tryGitConfigRead allremotes let allremotes' = catMaybes mayberemotes remotes' <- reposByUUID allremotes' uuids - if (0 == length remotes') - then err uuids - else return remotes' - err uuids = - error $ "no available git remotes have: " ++ - (keyFile key) ++ (uuidlist uuids) - uuidlist [] = "" - uuidlist uuids = "\nIt has been seen before in these repositories:\n" ++ - prettyPrintUUIDs uuids + return remotes' {- Cost Ordered list of remotes. -} remotesByCost :: Annex [Git.Repo] @@ -1,6 +1,9 @@ * bug when annexing files while in a subdir of a git repo * bug when specifying absolute path to files when annexing +* need to include backend name as part of the key, because currently + if two backends have overlapping key spaces, it can confuse things + * --push/--pull/--want * how to handle git mv file? |