testremote: Add testing of behavior when remote is not available

Added a mkUnavailable method, which a Remote can use to generate a version
of itself that is not available. Implemented for several, but not yet all
remotes.

This allows testing that checkPresent properly throws an exceptions when
it cannot check if a key is present or not. It also allows testing that the
other methods don't throw exceptions in these circumstances.

This immediately found several bugs, which this commit also fixes!

* git remotes using ssh accidentially had checkPresent return
  an exception, rather than throwing it
* The chunking code accidentially returned False rather than
  propigating an exception when there were no chunks and
  checkPresent threw an exception for the non-chunked key.

This commit was sponsored by Carlo Matteo Capocasa.
This commit is contained in:
Joey Hess 2014-08-10 14:52:58 -04:00
parent 2fd9518f72
commit 6adbd50cd9
18 changed files with 92 additions and 30 deletions

View file

@ -200,7 +200,7 @@ tryScan r
where where
p = proc cmd $ toCommand params p = proc cmd $ toCommand params
configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] [] configlist = Ssh.onRemote r (pipedconfig, return Nothing) "configlist" [] []
manualconfiglist = do manualconfiglist = do
gc <- Annex.getRemoteGitConfig r gc <- Annex.getRemoteGitConfig r
sshparams <- Ssh.toRepo r gc [Param sshcmd] sshparams <- Ssh.toRepo r gc [Param sshcmd]

View file

@ -62,13 +62,16 @@ start basesz ws = do
ks <- mapM randKey (keySizes basesz fast) ks <- mapM randKey (keySizes basesz fast)
rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast) rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast)
rs' <- concat <$> mapM encryptionVariants rs rs' <- concat <$> mapM encryptionVariants rs
next $ perform rs' ks unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r]
next $ perform rs' unavailrs ks
perform :: [Remote] -> [Key] -> CommandPerform perform :: [Remote] -> [Remote] -> [Key] -> CommandPerform
perform rs ks = do perform rs unavailrs ks = do
st <- Annex.getState id st <- Annex.getState id
let tests = testGroup "Remote Tests" $ let tests = testGroup "Remote Tests" $ concat
[ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ] [ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ]
, [ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ]
]
ok <- case tryIngredients [consoleTestReporter] mempty tests of ok <- case tryIngredients [consoleTestReporter] mempty tests of
Nothing -> error "No tests found!?" Nothing -> error "No tests found!?"
Just act -> liftIO act Just act -> liftIO act
@ -155,6 +158,28 @@ test st r k =
store = Remote.storeKey r k Nothing nullMeterUpdate store = Remote.storeKey r k Nothing nullMeterUpdate
remove = Remote.removeKey r k remove = Remote.removeKey r k
testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree]
testUnavailable st r k =
[ check (== Right False) "removeKey" $
Remote.removeKey r k
, check (== Right False) "storeKey" $
Remote.storeKey r k Nothing nullMeterUpdate
, check (`notElem` [Right True, Right False]) "checkPresent" $
Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $
getViaTmp k $ \dest ->
Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
, check (== Right False) "retrieveKeyFileCheap" $
getViaTmp k $ \dest ->
Remote.retrieveKeyFileCheap r k dest
]
where
check checkval desc a = testCase desc $ do
v <- Annex.eval st $ do
Annex.setOutput QuietOutput
either (Left . show) Right <$> tryNonAsync a
checkval v @? ("(got: " ++ show v ++ ")")
cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
cleanup rs ks ok = do cleanup rs ks ok = do
forM_ rs $ \r -> forM_ ks (Remote.removeKey r) forM_ rs $ \r -> forM_ ks (Remote.removeKey r)

View file

@ -72,6 +72,7 @@ gen r u c gc = do
, remotetype = remote , remotetype = remote
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable , availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
, readonly = False , readonly = False
, mkUnavailable = return Nothing
} }
return $ Just $ specialRemote' specialcfg c return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this buprepo) (simplyPrepare $ store this buprepo)

View file

@ -69,6 +69,7 @@ gen r u c gc = do
, remotetype = remote , remotetype = remote
, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable , availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
, readonly = False , readonly = False
, mkUnavailable = return Nothing
} }
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
specialcfg = (specialRemoteCfg c) specialcfg = (specialRemoteCfg c)

View file

@ -65,7 +65,9 @@ gen r u c gc = do
localpath = Just dir, localpath = Just dir,
readonly = False, readonly = False,
availability = LocallyAvailable, availability = LocallyAvailable,
remotetype = remote remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexDirectory = Just "/dev/null" }
} }
where where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
@ -196,5 +198,8 @@ checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
checkKey d _ k = liftIO $ checkKey d _ k = liftIO $
ifM (anyM doesFileExist (locations d k)) ifM (anyM doesFileExist (locations d k))
( return True ( return True
, error $ "directory " ++ d ++ " is not accessible" , ifM (doesDirectoryExist d)
( return False
, error $ "directory " ++ d ++ " is not accessible"
)
) )

View file

@ -65,7 +65,9 @@ gen r u c gc = do
gitconfig = gc, gitconfig = gc,
readonly = False, readonly = False,
availability = avail, availability = avail,
remotetype = remote remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexExternalType = Just "!dne!" }
} }
where where
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc) externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)

View file

@ -120,6 +120,7 @@ gen' r u c gc = do
, readonly = Git.repoIsHttp r , readonly = Git.repoIsHttp r
, availability = availabilityCalc r , availability = availabilityCalc r
, remotetype = remote , remotetype = remote
, mkUnavailable = return Nothing
} }
return $ Just $ specialRemote' specialcfg c return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this rsyncopts) (simplyPrepare $ store this rsyncopts)
@ -255,7 +256,7 @@ setupRepo gcryptid r
{- Ask git-annex-shell to configure the repository as a gcrypt {- Ask git-annex-shell to configure the repository as a gcrypt
- repository. May fail if it is too old. -} - repository. May fail if it is too old. -}
gitannexshellsetup = Ssh.onRemote r (boolSystem, False) gitannexshellsetup = Ssh.onRemote r (boolSystem, return False)
"gcryptsetup" [ Param gcryptid ] [] "gcryptsetup" [ Param gcryptid ] []
denyNonFastForwards = "receive.denyNonFastForwards" denyNonFastForwards = "receive.denyNonFastForwards"
@ -389,7 +390,7 @@ getGCryptId fast r
| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
liftIO (catchMaybeIO $ Git.Config.read r) liftIO (catchMaybeIO $ Git.Config.read r)
| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>) | not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)
[ Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] [] [ Ssh.onRemote r (Git.Config.fromPipe r, return (Left undefined)) "configlist" [] []
, getConfigViaRsync r , getConfigViaRsync r
] ]
| otherwise = return (Nothing, r) | otherwise = return (Nothing, r)

View file

@ -55,6 +55,7 @@ import Creds
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.MSampleVar import Control.Concurrent.MSampleVar
import qualified Data.Map as M import qualified Data.Map as M
import Network.URI
remote :: RemoteType remote :: RemoteType
remote = RemoteType { remote = RemoteType {
@ -156,8 +157,22 @@ gen r u c gc
, readonly = Git.repoIsHttp r , readonly = Git.repoIsHttp r
, availability = availabilityCalc r , availability = availabilityCalc r
, remotetype = remote , remotetype = remote
, mkUnavailable = unavailable r u c gc
} }
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
unavailable r u c gc = gen r' u c gc
where
r' = case Git.location r of
Git.Local { Git.gitdir = d } ->
r { Git.location = Git.LocalUnknown d }
Git.Url url -> case uriAuthority url of
Just auth ->
let auth' = auth { uriRegName = "!dne!" }
in r { Git.location = Git.Url (url { uriAuthority = Just auth' })}
Nothing -> r { Git.location = Git.Unknown }
_ -> r -- already unavailable
{- Checks relatively inexpensively if a repository is available for use. -} {- Checks relatively inexpensively if a repository is available for use. -}
repoAvail :: Git.Repo -> Annex Bool repoAvail :: Git.Repo -> Annex Bool
repoAvail r repoAvail r
@ -180,7 +195,7 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
tryGitConfigRead r tryGitConfigRead r
| haveconfig r = return r -- already read | haveconfig r = return r -- already read
| Git.repoIsSsh r = store $ do | Git.repoIsSsh r = store $ do
v <- Ssh.onRemote r (pipedconfig, Left undefined) "configlist" [] [] v <- Ssh.onRemote r (pipedconfig, return (Left undefined)) "configlist" [] []
case v of case v of
Right r' Right r'
| haveconfig r' -> return r' | haveconfig r' -> return r'
@ -298,8 +313,8 @@ inAnnex rmt key
) )
checkremote = Ssh.inAnnex r key checkremote = Ssh.inAnnex r key
checklocal = guardUsable r (cantCheck r) $ checklocal = guardUsable r (cantCheck r) $
fromMaybe (cantCheck r) maybe (cantCheck r) return
<$> onLocal rmt (Annex.Content.inAnnexSafe key) =<< onLocal rmt (Annex.Content.inAnnexSafe key)
keyUrls :: Remote -> Key -> [String] keyUrls :: Remote -> Key -> [String]
keyUrls r key = map tourl locs' keyUrls r key = map tourl locs'

View file

@ -65,7 +65,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
localpath = Nothing, localpath = Nothing,
readonly = False, readonly = False,
availability = GloballyAvailable, availability = GloballyAvailable,
remotetype = remote remotetype = remote,
mkUnavailable = return Nothing
} }
specialcfg = (specialRemoteCfg c) specialcfg = (specialRemoteCfg c)
-- Disabled until jobList gets support for chunks. -- Disabled until jobList gets support for chunks.

View file

@ -348,11 +348,12 @@ checkPresentChunks checker u chunkconfig encryptor basek
v <- check basek v <- check basek
case v of case v of
Right True -> return True Right True -> return True
Left e -> checklists (Just e) =<< chunkKeysOnly u basek
_ -> checklists Nothing =<< chunkKeysOnly u basek _ -> checklists Nothing =<< chunkKeysOnly u basek
| otherwise = checklists Nothing =<< chunkKeys u chunkconfig basek | otherwise = checklists Nothing =<< chunkKeys u chunkconfig basek
where where
checklists Nothing [] = return False checklists Nothing [] = return False
checklists (Just deferrederror) [] = error deferrederror checklists (Just deferrederror) [] = throwM deferrederror
checklists d (l:ls) checklists d (l:ls)
| not (null l) = do | not (null l) = do
v <- checkchunks l v <- checkchunks l
@ -362,14 +363,14 @@ checkPresentChunks checker u chunkconfig encryptor basek
Right False -> checklists Nothing ls Right False -> checklists Nothing ls
| otherwise = checklists d ls | otherwise = checklists d ls
checkchunks :: [Key] -> Annex (Either String Bool) checkchunks :: [Key] -> Annex (Either SomeException Bool)
checkchunks [] = return (Right True) checkchunks [] = return (Right True)
checkchunks (k:ks) = do checkchunks (k:ks) = do
v <- check k v <- check k
case v of case v of
Right True -> checkchunks ks Right True -> checkchunks ks
Right False -> return $ Right False Right False -> return $ Right False
Left e -> return $ Left $ show e Left e -> return $ Left e
check = tryNonAsync . checker . encryptor check = tryNonAsync . checker . encryptor

View file

@ -69,7 +69,7 @@ git_annex_shell r command params fields
- a specified error value. -} - a specified error value. -}
onRemote onRemote
:: Git.Repo :: Git.Repo
-> (FilePath -> [CommandParam] -> IO a, a) -> (FilePath -> [CommandParam] -> IO a, Annex a)
-> String -> String
-> [CommandParam] -> [CommandParam]
-> [(Field, String)] -> [(Field, String)]
@ -78,7 +78,7 @@ onRemote r (with, errorval) command params fields = do
s <- git_annex_shell r command params fields s <- git_annex_shell r command params fields
case s of case s of
Just (c, ps) -> liftIO $ with c ps Just (c, ps) -> liftIO $ with c ps
Nothing -> return errorval Nothing -> errorval
{- Checks if a remote contains a key. -} {- Checks if a remote contains a key. -}
inAnnex :: Git.Repo -> Key -> Annex Bool inAnnex :: Git.Repo -> Key -> Annex Bool
@ -86,14 +86,14 @@ inAnnex r k = do
showChecking r showChecking r
onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] [] onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] []
where where
check c p = dispatch <$> safeSystem c p check c p = dispatch =<< safeSystem c p
dispatch ExitSuccess = True dispatch ExitSuccess = return True
dispatch (ExitFailure 1) = False dispatch (ExitFailure 1) = return False
dispatch _ = cantCheck r dispatch _ = cantCheck r
{- Removes a key from a remote. -} {- Removes a key from a remote. -}
dropKey :: Git.Repo -> Key -> Annex Bool dropKey :: Git.Repo -> Key -> Annex Bool
dropKey r key = onRemote r (boolSystem, False) "dropkey" dropKey r key = onRemote r (boolSystem, return False) "dropkey"
[ Params "--quiet --force" [ Params "--quiet --force"
, Param $ key2file key , Param $ key2file key
] ]

View file

@ -58,7 +58,9 @@ gen r u c gc = do
gitconfig = gc, gitconfig = gc,
readonly = False, readonly = False,
availability = GloballyAvailable, availability = GloballyAvailable,
remotetype = remote remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexHookType = Just "!dne!" }
} }
where where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc

View file

@ -82,6 +82,7 @@ gen r u c gc = do
, readonly = False , readonly = False
, availability = if islocal then LocallyAvailable else GloballyAvailable , availability = if islocal then LocallyAvailable else GloballyAvailable
, remotetype = remote , remotetype = remote
, mkUnavailable = return Nothing
} }
where where
specialcfg = (specialRemoteCfg c) specialcfg = (specialRemoteCfg c)

View file

@ -70,7 +70,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
localpath = Nothing, localpath = Nothing,
readonly = False, readonly = False,
availability = GloballyAvailable, availability = GloballyAvailable,
remotetype = remote remotetype = remote,
mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
} }
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)

View file

@ -83,7 +83,8 @@ gen r u c gc = do
localpath = Nothing, localpath = Nothing,
readonly = False, readonly = False,
availability = GloballyAvailable, availability = GloballyAvailable,
remotetype = remote remotetype = remote,
mkUnavailable = return Nothing
} }
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)

View file

@ -61,7 +61,8 @@ gen r _ c gc =
repo = r, repo = r,
readonly = True, readonly = True,
availability = GloballyAvailable, availability = GloballyAvailable,
remotetype = remote remotetype = remote,
mkUnavailable = return Nothing
} }
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool

View file

@ -70,7 +70,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
localpath = Nothing, localpath = Nothing,
readonly = False, readonly = False,
availability = GloballyAvailable, availability = GloballyAvailable,
remotetype = remote remotetype = remote,
mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
} }
chunkconfig = getChunkConfig c chunkconfig = getChunkConfig c

View file

@ -95,7 +95,10 @@ data RemoteA a = Remote {
-- a Remote can be globally available. (Ie, "in the cloud".) -- a Remote can be globally available. (Ie, "in the cloud".)
availability :: Availability, availability :: Availability,
-- the type of the remote -- the type of the remote
remotetype :: RemoteTypeA a remotetype :: RemoteTypeA a,
-- For testing, makes a version of this remote that is not
-- available for use. All its actions should fail.
mkUnavailable :: a (Maybe (RemoteA a))
} }
instance Show (RemoteA a) where instance Show (RemoteA a) where