improved messages when a file is not available in remotes
This commit is contained in:
parent
ed3f6653b6
commit
4f8d28819d
2 changed files with 32 additions and 36 deletions
|
@ -55,15 +55,15 @@ copyKeyFile key file = do
|
||||||
remotes <- Remotes.withKey key
|
remotes <- Remotes.withKey key
|
||||||
if (0 == length remotes)
|
if (0 == length remotes)
|
||||||
then do
|
then do
|
||||||
showNote $ "No available git remotes have the file."
|
showNote "not available"
|
||||||
showLocations key
|
showLocations key
|
||||||
return False
|
return False
|
||||||
else trycopy remotes remotes
|
else trycopy remotes remotes
|
||||||
where
|
where
|
||||||
trycopy full [] = do
|
trycopy full [] = do
|
||||||
showNote $
|
showNote "not available"
|
||||||
"need access to one of these remotes: " ++
|
showTriedRemotes full
|
||||||
(Remotes.list full)
|
showLocations key
|
||||||
return False
|
return False
|
||||||
trycopy full (r:rs) = do
|
trycopy full (r:rs) = do
|
||||||
-- annexLocation needs the git config to have been
|
-- annexLocation needs the git config to have been
|
||||||
|
@ -71,8 +71,8 @@ copyKeyFile key file = do
|
||||||
-- if it hasn't been already
|
-- if it hasn't been already
|
||||||
result <- Remotes.tryGitConfigRead r
|
result <- Remotes.tryGitConfigRead r
|
||||||
case (result) of
|
case (result) of
|
||||||
Nothing -> trycopy full rs
|
Left err -> trycopy full rs
|
||||||
Just r' -> do
|
Right r' -> do
|
||||||
showNote $ "copying from " ++ (Git.repoDescribe r ) ++ "..."
|
showNote $ "copying from " ++ (Git.repoDescribe r ) ++ "..."
|
||||||
liftIO $ copyFromRemote r' key file
|
liftIO $ copyFromRemote r' key file
|
||||||
|
|
||||||
|
@ -86,7 +86,7 @@ copyFromRemote r key file = do
|
||||||
getlocal = boolSystem "cp" ["-a", location, file]
|
getlocal = boolSystem "cp" ["-a", location, file]
|
||||||
getremote = return False -- TODO implement get from remote
|
getremote = return False -- TODO implement get from remote
|
||||||
location = annexLocation r key
|
location = annexLocation r key
|
||||||
|
|
||||||
showLocations :: Key -> Annex ()
|
showLocations :: Key -> Annex ()
|
||||||
showLocations key = do
|
showLocations key = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
|
@ -97,6 +97,10 @@ showLocations key = do
|
||||||
if (0 < length uuidsf)
|
if (0 < length uuidsf)
|
||||||
then showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
|
then showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
|
||||||
else showLongNote $ "No other repository is known to contain the file."
|
else showLongNote $ "No other repository is known to contain the file."
|
||||||
|
|
||||||
|
showTriedRemotes remotes =
|
||||||
|
showLongNote $ "I was unable to access these remotes: " ++
|
||||||
|
(Remotes.list remotes)
|
||||||
|
|
||||||
{- Checks remotes to verify that enough copies of a key exist to allow
|
{- 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
|
- for a key to be safely removed (with no data loss), and fails with an
|
||||||
|
@ -108,46 +112,37 @@ checkRemoveKey key = do
|
||||||
then return True
|
then return True
|
||||||
else do
|
else do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
let numcopies = read $ Git.configGet g config "1"
|
|
||||||
remotes <- Remotes.withKey key
|
remotes <- Remotes.withKey key
|
||||||
|
let numcopies = read $ Git.configGet g config "1"
|
||||||
if (numcopies > length remotes)
|
if (numcopies > length remotes)
|
||||||
then retNotEnoughCopiesKnown remotes numcopies
|
then notEnoughCopies numcopies (length remotes) []
|
||||||
else findcopies numcopies remotes []
|
else findcopies numcopies 0 remotes []
|
||||||
where
|
where
|
||||||
config = "annex.numcopies"
|
config = "annex.numcopies"
|
||||||
|
findcopies need have [] bad =
|
||||||
findcopies 0 _ _ = return True -- success, enough copies found
|
if (have >= need)
|
||||||
findcopies _ [] bad = notEnoughCopiesSeen bad
|
then return True
|
||||||
findcopies n (r:rs) bad = do
|
else notEnoughCopies need have bad
|
||||||
|
findcopies need have (r:rs) bad = do
|
||||||
all <- Annex.supportedBackends
|
all <- Annex.supportedBackends
|
||||||
result <- liftIO $ ((try $ remoteHasKey r all)::IO (Either SomeException Bool))
|
result <- liftIO $ ((try $ remoteHasKey r all)::IO (Either SomeException Bool))
|
||||||
case (result) of
|
case (result) of
|
||||||
Right True -> findcopies (n-1) rs bad
|
Right True -> findcopies need (have+1) rs bad
|
||||||
Right False -> findcopies n rs bad
|
Right False -> findcopies need have rs bad
|
||||||
Left _ -> findcopies n rs (r:bad)
|
Left _ -> findcopies need have rs (r:bad)
|
||||||
remoteHasKey r all = do
|
remoteHasKey r all = do
|
||||||
-- To check if a remote has a key, construct a new
|
-- To check if a remote has a key, construct a new
|
||||||
-- Annex monad and query its backend.
|
-- Annex monad and query its backend.
|
||||||
a <- Annex.new r all
|
a <- Annex.new r all
|
||||||
(result, _) <- Annex.run a (Backend.hasKey key)
|
(result, _) <- Annex.run a (Backend.hasKey key)
|
||||||
return result
|
return result
|
||||||
notEnoughCopiesSeen bad = do
|
notEnoughCopies need have bad = do
|
||||||
unsafe
|
|
||||||
if (0 /= length bad) then listbad bad else return ()
|
|
||||||
showLocations key
|
|
||||||
hint
|
|
||||||
return False
|
|
||||||
listbad bad =
|
|
||||||
showLongNote $
|
|
||||||
"I was unable to access these remotes: " ++
|
|
||||||
(Remotes.list bad)
|
|
||||||
retNotEnoughCopiesKnown remotes numcopies = do
|
|
||||||
unsafe
|
unsafe
|
||||||
showLongNote $
|
showLongNote $
|
||||||
"Could only verify the existence of " ++
|
"Could only verify the existence of " ++
|
||||||
(show $ length remotes) ++
|
(show have) ++ " out of " ++ (show need) ++
|
||||||
" out of " ++ (show numcopies) ++
|
|
||||||
" necessary copies"
|
" necessary copies"
|
||||||
|
if (0 /= length bad) then showTriedRemotes bad else return ()
|
||||||
showLocations key
|
showLocations key
|
||||||
hint
|
hint
|
||||||
return False
|
return False
|
||||||
|
|
13
Remotes.hs
13
Remotes.hs
|
@ -10,6 +10,7 @@ import Control.Exception
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
|
import Data.Either.Utils
|
||||||
import List
|
import List
|
||||||
import Maybe
|
import Maybe
|
||||||
|
|
||||||
|
@ -42,8 +43,8 @@ withKey key = do
|
||||||
where
|
where
|
||||||
tryharder allremotes uuids = do
|
tryharder allremotes uuids = do
|
||||||
-- more expensive; read each remote's config
|
-- more expensive; read each remote's config
|
||||||
mayberemotes <- mapM tryGitConfigRead allremotes
|
eitherremotes <- mapM tryGitConfigRead allremotes
|
||||||
let allremotes' = catMaybes mayberemotes
|
let allremotes' = map fromEither eitherremotes
|
||||||
remotes' <- reposByUUID allremotes' uuids
|
remotes' <- reposByUUID allremotes' uuids
|
||||||
Annex.flagChange RemotesRead True
|
Annex.flagChange RemotesRead True
|
||||||
return remotes'
|
return remotes'
|
||||||
|
@ -86,7 +87,7 @@ repoCost r = do
|
||||||
- because reading it may be expensive. This function tries to read the
|
- because reading it may be expensive. This function tries to read the
|
||||||
- config for a specified remote, and updates state. If successful, it
|
- config for a specified remote, and updates state. If successful, it
|
||||||
- returns the updated git repo. -}
|
- returns the updated git repo. -}
|
||||||
tryGitConfigRead :: Git.Repo -> Annex (Maybe Git.Repo)
|
tryGitConfigRead :: Git.Repo -> Annex (Either Git.Repo Git.Repo)
|
||||||
tryGitConfigRead r = do
|
tryGitConfigRead r = do
|
||||||
if (Map.null $ Git.configMap r)
|
if (Map.null $ Git.configMap r)
|
||||||
then do
|
then do
|
||||||
|
@ -94,15 +95,15 @@ tryGitConfigRead r = do
|
||||||
-- for other reasons; catch all possible exceptions
|
-- for other reasons; catch all possible exceptions
|
||||||
result <- liftIO $ (try (Git.configRead r)::IO (Either SomeException (Git.Repo)))
|
result <- liftIO $ (try (Git.configRead r)::IO (Either SomeException (Git.Repo)))
|
||||||
case (result) of
|
case (result) of
|
||||||
Left err -> return Nothing
|
Left err -> return $ Left r
|
||||||
Right r' -> do
|
Right r' -> do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
let l = Git.remotes g
|
let l = Git.remotes g
|
||||||
let g' = Git.remotesAdd g $
|
let g' = Git.remotesAdd g $
|
||||||
exchange l r'
|
exchange l r'
|
||||||
Annex.gitRepoChange g'
|
Annex.gitRepoChange g'
|
||||||
return $ Just r'
|
return $ Right r'
|
||||||
else return $ Just r
|
else return $ Right r -- config already read
|
||||||
where
|
where
|
||||||
exchange [] new = []
|
exchange [] new = []
|
||||||
exchange (old:ls) new =
|
exchange (old:ls) new =
|
||||||
|
|
Loading…
Reference in a new issue