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:
parent
ee37d478f8
commit
1d0bf44173
5 changed files with 85 additions and 7 deletions
CHANGELOG
Command
doc
git-annex-testremote.mdwn
todo
Test_cases_for_exporttree_special_remotes.mdwn
Test_cases_for_exporttree_special_remotes
|
@ -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
|
||||
|
||||
|
|
|
@ -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" $
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -1 +1,3 @@
|
|||
As far as I can tell, `git annex testremote` doesn't test exporting yet
|
||||
|
||||
> [[fixed|done]] --[[Joey]]
|
||||
|
|
|
@ -0,0 +1,7 @@
|
|||
[[!comment format=mdwn
|
||||
username="joey"
|
||||
subject="""comment 2"""
|
||||
date="2017-11-08T17:38:02Z"
|
||||
content="""
|
||||
Added some fairly comprehensive tests.
|
||||
"""]]
|
Loading…
Reference in a new issue