From 1d0bf44173cd1c207cde8b1155d32ec338b7deaa Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Nov 2017 14:22:05 -0400 Subject: [PATCH] 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. --- CHANGELOG | 1 + Command/TestRemote.hs | 79 +++++++++++++++++-- doc/git-annex-testremote.mdwn | 3 +- ..._cases_for_exporttree_special_remotes.mdwn | 2 + ..._0e280ec5691dbb0eef68f6e6c1424d08._comment | 7 ++ 5 files changed, 85 insertions(+), 7 deletions(-) create mode 100644 doc/todo/Test_cases_for_exporttree_special_remotes/comment_2_0e280ec5691dbb0eef68f6e6c1424d08._comment diff --git a/CHANGELOG b/CHANGELOG index 358abb4f5b..faa05e3d26 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -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 Mon, 30 Oct 2017 12:01:45 -0400 diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 8a21fdf350..75e438d79f 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -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" $ diff --git a/doc/git-annex-testremote.mdwn b/doc/git-annex-testremote.mdwn index 5c3a5ca5b0..a6793066c3 100644 --- a/doc/git-annex-testremote.mdwn +++ b/doc/git-annex-testremote.mdwn @@ -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 diff --git a/doc/todo/Test_cases_for_exporttree_special_remotes.mdwn b/doc/todo/Test_cases_for_exporttree_special_remotes.mdwn index 4433697403..3d32b2c710 100644 --- a/doc/todo/Test_cases_for_exporttree_special_remotes.mdwn +++ b/doc/todo/Test_cases_for_exporttree_special_remotes.mdwn @@ -1 +1,3 @@ As far as I can tell, `git annex testremote` doesn't test exporting yet + +> [[fixed|done]] --[[Joey]] diff --git a/doc/todo/Test_cases_for_exporttree_special_remotes/comment_2_0e280ec5691dbb0eef68f6e6c1424d08._comment b/doc/todo/Test_cases_for_exporttree_special_remotes/comment_2_0e280ec5691dbb0eef68f6e6c1424d08._comment new file mode 100644 index 0000000000..5cbb24e598 --- /dev/null +++ b/doc/todo/Test_cases_for_exporttree_special_remotes/comment_2_0e280ec5691dbb0eef68f6e6c1424d08._comment @@ -0,0 +1,7 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 2""" + date="2017-11-08T17:38:02Z" + content=""" +Added some fairly comprehensive tests. +"""]]