testremote: Support testing readonly remotes with the --test-readonly option

This commit was sponsored by Ilya Shlyakhter on Patreon.
This commit is contained in:
Joey Hess 2019-01-17 12:39:29 -04:00
parent 8230b62e06
commit 8555169e71
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 89 additions and 38 deletions

View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2014 Joey Hess <id@joeyh.name>
- Copyright 2014-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -14,7 +14,9 @@ import qualified Types.Remote as Remote
import qualified Types.Backend as Backend
import Types.KeySource
import Annex.Content
import Annex.WorkTree
import Backend
import Logs.Location
import qualified Backend.Hash
import Utility.Tmp
import Utility.Metered
@ -42,6 +44,7 @@ cmd = command "testremote" SectionTesting
data TestRemoteOptions = TestRemoteOptions
{ testRemote :: RemoteName
, sizeOption :: ByteSize
, testReadonlyFile :: [FilePath]
}
optParser :: CmdParamsDesc -> Parser TestRemoteOptions
@ -52,22 +55,43 @@ optParser desc = TestRemoteOptions
<> value (1024 * 1024)
<> help "base key size (default 1MiB)"
)
<*> many testreadonly
where
testreadonly = option str
( long "test-readonly" <> metavar paramFile
<> help "readonly test object"
)
seek :: TestRemoteOptions -> CommandSeek
seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o)
seek = commandAction . start
start :: Int -> RemoteName -> CommandStart
start basesz name = do
showStart' "testremote" (Just name)
start :: TestRemoteOptions -> CommandStart
start o = do
showStart' "testremote" (Just (testRemote o))
fast <- Annex.getState Annex.fast
r <- either giveup disableExportTree =<< Remote.byName' name
rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast)
rs' <- concat <$> mapM encryptionVariants rs
unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r]
exportr <- exportTreeVariant r
showAction "generating test keys"
ks <- mapM randKey (keySizes basesz fast)
next $ perform rs' unavailrs exportr ks
r <- either giveup disableExportTree =<< Remote.byName' (testRemote o)
ks <- case testReadonlyFile o of
[] -> if Remote.readonly r
then giveup "This remote is readonly, so you need to use the --test-readonly option."
else do
showAction "generating test keys"
mapM randKey (keySizes basesz fast)
fs -> mapM (getReadonlyKey r) fs
let r' = if null (testReadonlyFile o)
then r
else r { Remote.readonly = True }
rs <- if Remote.readonly r'
then return [r']
else do
rs <- catMaybes <$> mapM (adjustChunkSize r') (chunkSizes basesz fast)
concat <$> mapM encryptionVariants rs
unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r']
exportr <- if Remote.readonly r'
then return Nothing
else exportTreeVariant r'
next $ perform rs unavailrs exportr ks
where
basesz = fromInteger $ sizeOption o
perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform
perform rs unavailrs exportr ks = do
@ -132,18 +156,18 @@ adjustRemoteConfig r adjustconfig = do
(Remote.gitconfig r)
test :: Annex.AnnexState -> Remote -> Key -> [TestTree]
test st r k =
[ check "removeKey when not present" remove
, present False
, check "storeKey" store
, present True
, check "storeKey when already present" store
, present True
, check "retrieveKeyFile" $ do
test st r k = catMaybes
[ whenwritable $ check "removeKey when not present" remove
, whenwritable $ present False
, whenwritable $ check "storeKey" store
, whenwritable $ present True
, whenwritable $ check "storeKey when already present" store
, whenwritable $ present True
, Just $ check "retrieveKeyFile" $ do
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 33%" $ do
, Just $ check "fsck downloaded object" fsck
, Just $ check "retrieveKeyFile resume from 33%" $ do
loc <- Annex.calcRepo (gitAnnexLocation k)
tmp <- prepTmp k
partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
@ -152,24 +176,25 @@ test st r k =
liftIO $ L.writeFile tmp partial
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 0" $ do
, Just $ check "fsck downloaded object" fsck
, Just $ check "retrieveKeyFile resume from 0" $ do
tmp <- prepTmp k
liftIO $ writeFile tmp ""
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from end" $ do
, Just $ check "fsck downloaded object" fsck
, Just $ check "retrieveKeyFile resume from end" $ do
loc <- Annex.calcRepo (gitAnnexLocation k)
tmp <- prepTmp k
void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp
lockContentForRemoval k removeAnnex
get
, check "fsck downloaded object" fsck
, check "removeKey when present" remove
, present False
, Just $ check "fsck downloaded object" fsck
, whenwritable $ check "removeKey when present" remove
, whenwritable $ present False
]
where
whenwritable a = if Remote.readonly r then Nothing else Just a
check desc a = testCase desc $
Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"
present b = check ("present " ++ show b) $
@ -252,10 +277,12 @@ testUnavailable st r k =
checkval v @? ("(got: " ++ show v ++ ")")
cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
cleanup rs ks ok = do
forM_ rs $ \r -> forM_ ks (Remote.removeKey r)
forM_ ks $ \k -> lockContentForRemoval k removeAnnex
return ok
cleanup rs ks ok
| all Remote.readonly rs = return ok
| otherwise = do
forM_ rs $ \r -> forM_ ks (Remote.removeKey r)
forM_ ks $ \k -> lockContentForRemoval k removeAnnex
return ok
chunkSizes :: Int -> Bool -> [Int]
chunkSizes base False =
@ -297,3 +324,13 @@ randKey sz = withTmpFile "randkey" $ \f h -> do
<$> Backend.getKey Backend.Hash.testKeyBackend ks
_ <- moveAnnex k f
return k
getReadonlyKey :: Remote -> FilePath -> Annex Key
getReadonlyKey r f = lookupFile f >>= \case
Nothing -> giveup $ f ++ " is not an annexed file"
Just k -> do
unlessM (inAnnex k) $
giveup $ f ++ " does not have its content locally present, cannot test it"
unlessM ((Remote.uuid r `elem`) <$> loggedLocations k) $
giveup $ f ++ " is not stored in the remote being tested, cannot test it"
return k