testremote: Test exporttree.

As long as the class of remotes supports exporting, it's tested whether
or not the remote is configured with exporttree=yes.

Also, made testremote of a remote configured with exporttree=yes
disable that configuration for testing non-export storage.

This commit was supported by the NSF-funded DataLad project.
This commit is contained in:
Joey Hess 2017-11-08 14:22:05 -04:00
parent ee37d478f8
commit 1d0bf44173
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 85 additions and 7 deletions

View file

@ -9,6 +9,7 @@ git-annex (6.20171027) UNRELEASED; urgency=medium
* Makefile improvement for sudo make install.
Thanks, Eric Siegerman
* Makefile improvement for BUILDER=stack, use stack to run ghc.
* testremote: Test exporttree.
-- Joey Hess <id@joeyh.name> Mon, 30 Oct 2017 12:01:45 -0400

View file

@ -21,6 +21,8 @@ import Utility.Metered
import Utility.DataUnits
import Utility.CopyFile
import Types.Messages
import Types.Export
import Remote.Helper.Export
import Remote.Helper.Chunked
import Git.Types
@ -57,21 +59,24 @@ seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o)
start :: Int -> RemoteName -> CommandStart
start basesz name = do
showStart "testremote" name
r <- either giveup id <$> Remote.byName' name
showAction "generating test keys"
fast <- Annex.getState Annex.fast
ks <- mapM randKey (keySizes basesz 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]
next $ perform rs' unavailrs ks
exportr <- exportTreeVariant r
showAction "generating test keys"
ks <- mapM randKey (keySizes basesz fast)
next $ perform rs' unavailrs exportr ks
perform :: [Remote] -> [Remote] -> [Key] -> CommandPerform
perform rs unavailrs ks = do
perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform
perform rs unavailrs exportr ks = do
ea <- maybe exportUnsupported Remote.exportActions exportr
st <- Annex.getState id
let tests = testGroup "Remote Tests" $ concat
[ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ]
, [ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ]
, [ testGroup (descexport k1 k2) (testExportTree st exportr ea k1 k2) | k1 <- take 2 ks, k2 <- take 2 (reverse ks) ]
]
ok <- case tryIngredients [consoleTestReporter] mempty tests of
Nothing -> error "No tests found!?"
@ -83,6 +88,11 @@ perform rs unavailrs ks = do
, [ show (getChunkConfig (Remote.config r')) ]
, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
]
descexport k1 k2 = intercalate "; " $ map unwords
[ [ "exporttree=yes" ]
, [ "key1 size", show (keySize k1) ]
, [ "key2 size", show (keySize k2) ]
]
adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)
adjustChunkSize r chunksize = adjustRemoteConfig r
@ -98,6 +108,19 @@ encryptionVariants r = do
M.insert "highRandomQuality" "false"
return $ catMaybes [noenc, sharedenc]
-- Variant of a remote with exporttree disabled.
disableExportTree :: Remote -> Annex Remote
disableExportTree r = maybe (error "failed disabling exportreee") return
=<< adjustRemoteConfig r (M.delete "exporttree")
-- Variant of a remote with exporttree enabled.
exportTreeVariant :: Remote -> Annex (Maybe Remote)
exportTreeVariant r = ifM (Remote.isExportSupported r)
( adjustRemoteConfig r $
M.insert "encryption" "none" . M.insert "exporttree" "yes"
, return Nothing
)
-- Regenerate a remote with a modified config.
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
adjustRemoteConfig r adjustconfig = Remote.generate (Remote.remotetype r)
@ -160,6 +183,50 @@ test st r k =
store = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
remove = Remote.removeKey r k
testExportTree :: Annex.AnnexState -> Maybe Remote -> Remote.ExportActions Annex -> Key -> Key -> [TestTree]
testExportTree _ Nothing _ _ _ = []
testExportTree st (Just _) ea k1 k2 =
[ check "check present export when not present" $
not <$> checkpresentexport k1
, check "remove export when not present" (removeexport k1)
, check "store export" (storeexport k1)
, check "check present export after store" $
checkpresentexport k1
, check "store export when already present" (storeexport k1)
, check "retrieve export" (retrieveexport k1)
, check "store new content to export" (storeexport k2)
, check "check present export after store of new content" $
checkpresentexport k2
, check "retrieve export new content" (retrieveexport k2)
, check "remove export" (removeexport k2)
, check "check present export after remove" $
not <$> checkpresentexport k2
, check "retrieve export fails after removal" $
not <$> retrieveexport k2
, check "remove export directory" removeexportdirectory
, check "remove export directory that is already removed" removeexportdirectory
-- renames are not tested because remotes do not need to support them
]
where
testexportdirectory = "testremote-export"
testexportlocation = mkExportLocation (testexportdirectory </> "location")
check desc a = testCase desc $
Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"
storeexport k = do
loc <- Annex.calcRepo (gitAnnexLocation k)
Remote.storeExport ea loc k testexportlocation nullMeterUpdate
retrieveexport k = withTmpFile "exported" $ \tmp h -> do
liftIO $ hClose h
ifM (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate)
( verifyKeyContent AlwaysVerify UnVerified k tmp
, return False
)
checkpresentexport k = Remote.checkPresentExport ea k testexportlocation
removeexport k = Remote.removeExport ea k testexportlocation
removeexportdirectory = case Remote.removeExportDirectory ea of
Nothing -> return True
Just a -> a (mkExportDirectory testexportdirectory)
testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree]
testUnavailable st r k =
[ check (== Right False) "removeKey" $

View file

@ -19,7 +19,8 @@ tries to clean up after itself, if the remote being tested had a bug,
the cleanup might fail, leaving test data in the remote.
Testing will use the remote's configuration, automatically varying
the chunk sizes, and with simple shared encryption enabled and disabled.
the chunk sizes, and with simple shared encryption disabled and enabled,
and exporttree disabled and enabled.
# OPTIONS

View file

@ -1 +1,3 @@
As far as I can tell, `git annex testremote` doesn't test exporting yet
> [[fixed|done]] --[[Joey]]

View file

@ -0,0 +1,7 @@
[[!comment format=mdwn
username="joey"
subject="""comment 2"""
date="2017-11-08T17:38:02Z"
content="""
Added some fairly comprehensive tests.
"""]]