From 9fa940569c7941ad794637017ae5296e657c7f8d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 30 Apr 2020 13:49:22 -0400 Subject: [PATCH] added remote variants Todo item is done at last. Might later want to think about testing some other types of remotes that can be tested locally. The git remote itself is probably already well enough tested by the test suite that testremote is not needed. Could test things like bup, or rsync to a local directory. Or even external, although that would require embedding an external special remote program into the test suite.. --- Command/TestRemote.hs | 70 +++++++++++++++++++---------------- Test.hs | 38 +++++++++++-------- doc/todo/test_testremote.mdwn | 2 + 3 files changed, 64 insertions(+), 46 deletions(-) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index d538b5ed5a..df4606b586 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -30,7 +30,7 @@ import Types.RemoteConfig import Types.ProposedAccepted import Annex.SpecialRemote.Config (exportTreeField) import Remote.Helper.Chunked -import Remote.Helper.Encryptable (describeEncryption, encryptionField, highRandomQualityField) +import Remote.Helper.Encryptable (encryptionField, highRandomQualityField) import Git.Types import Test.Tasty @@ -85,56 +85,63 @@ start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do let r' = if null (testReadonlyFile o) then r else r { Remote.readonly = True } - rs <- if Remote.readonly r' - then return [r'] - else remoteVariants r' basesz fast + let drs = if Remote.readonly r' + then [Described "remote" (pure (Just r'))] + else remoteVariants (Described "remote" (pure r')) basesz fast unavailr <- Remote.mkUnavailable r' let exportr = if Remote.readonly r' then return Nothing else exportTreeVariant r' - perform rs unavailr exportr ks + perform drs unavailr exportr ks where basesz = fromInteger $ sizeOption o -remoteVariants :: Remote -> Int -> Bool -> Annex [Remote] -remoteVariants r basesz fast = do - rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast) - concat <$> mapM encryptionVariants rs - -perform :: [Remote] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform -perform rs unavailr exportr ks = do +perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform +perform drs unavailr exportr ks = do st <- liftIO . newTVarIO =<< Annex.getState id let tests = testGroup "Remote Tests" $ mkTestTrees (runTestCase st) - (map (\r -> Described (descr r) (pure r)) rs) + drs (pure unavailr) exportr (map (\k -> Described (desck k) (pure k)) ks) ok <- case tryIngredients [consoleTestReporter] mempty tests of Nothing -> error "No tests found!?" Just act -> liftIO act + rs <- catMaybes <$> mapM getVal drs next $ cleanup rs ks ok where - descr r = intercalate "; " $ map unwords - [ [ show (getChunkConfig (Remote.config r)) ] - , ["encryption", describeEncryption (Remote.config r)] - ] desck k = unwords [ "key size", show (fromKey keySize k) ] +remoteVariants :: Described (Annex Remote) -> Int -> Bool -> [Described (Annex (Maybe Remote))] +remoteVariants dr basesz fast = + concatMap encryptionVariants $ + map chunkvariant (chunkSizes basesz fast) + where + chunkvariant sz = Described (getDesc dr ++ " chunksize=" ++ show sz) $ do + r <- getVal dr + adjustChunkSize r sz + adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) adjustChunkSize r chunksize = adjustRemoteConfig r $ M.insert chunkField (Proposed (show chunksize)) -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested. -encryptionVariants :: Remote -> Annex [Remote] -encryptionVariants r = do - noenc <- adjustRemoteConfig r $ - M.insert encryptionField (Proposed "none") - sharedenc <- adjustRemoteConfig r $ - M.insert encryptionField (Proposed "shared") . - M.insert highRandomQualityField (Proposed "false") - return $ catMaybes [noenc, sharedenc] +encryptionVariants :: Described (Annex (Maybe Remote)) -> [Described (Annex (Maybe Remote))] +encryptionVariants dr = [noenc, sharedenc] + where + noenc = Described (getDesc dr ++ " encryption=none") $ + getVal dr >>= \case + Nothing -> return Nothing + Just r -> adjustRemoteConfig r $ + M.insert encryptionField (Proposed "none") + sharedenc = Described (getDesc dr ++ " encryption=shared") $ + getVal dr >>= \case + Nothing -> return Nothing + Just r -> adjustRemoteConfig r $ + M.insert encryptionField (Proposed "shared") . + M.insert highRandomQualityField (Proposed "false") -- Variant of a remote with exporttree disabled. disableExportTree :: Remote -> Annex Remote @@ -182,7 +189,7 @@ runTestCase stv a = do -- the provided actions are called. mkTestTrees :: RunAnnex - -> [Described (Annex Remote)] + -> [Described (Annex (Maybe Remote))] -> Annex (Maybe Remote) -> Annex (Maybe Remote) -> [Described (Annex Key)] @@ -203,7 +210,7 @@ mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $ , [ getDesc k2 ] ] -test :: RunAnnex -> Annex Remote -> Annex Key -> [TestTree] +test :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree] test runannex mkr mkk = [ check "removeKey when not present" $ \r k -> whenwritable r $ remove r k @@ -253,10 +260,11 @@ test runannex mkr mkk = | Remote.readonly r = return True | otherwise = a check desc a = testCase desc $ do - let a' = do - r <- mkr - k <- mkk - a r k + let a' = mkr >>= \case + Just r -> do + k <- mkk + a r k + Nothing -> return True runannex a' @? "failed" present r k b = (== Right b) <$> Remote.hasKey r k fsck _ k = case maybeLookupBackendVariety (fromKey keyVariety k) of diff --git a/Test.hs b/Test.hs index a257e2cb0a..7f79fafdd6 100644 --- a/Test.hs +++ b/Test.hs @@ -148,7 +148,7 @@ ingredients = tests :: Bool -> Bool -> TestOptions -> TestTree tests crippledfilesystem adjustedbranchok opts = testGroup "Tests" $ properties - : withTestMode remotetestmode Nothing testRemote + : withTestMode remotetestmode Nothing testRemotes : map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes where testmodes = catMaybes @@ -207,16 +207,25 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $ , Utility.Hash.props_macs_stable ] -testRemote :: TestTree -testRemote = withResource newEmptyTMVarIO (const noop) $ \getv -> - testGroup "Remote Tests" $ concat - [ [testCase "init" (prep getv)] - , go getv +testRemotes :: TestTree +testRemotes = testGroup "Remote Tests" + [ testRemote "directory" + [ "directory=remotedir" + , "encryption=none" ] + (createDirectory "remotedir") + ] + +testRemote :: String -> [String] -> IO () -> TestTree +testRemote remotetype config preinitremote = + withResource newEmptyTMVarIO (const noop) $ \getv -> + testGroup ("remote type " ++ remotetype) $ concat + [ [testCase "init" (prep getv)] + , go getv + ] where reponame = "test repo" - remotename = "dir" - remotetype =" directory" + remotename = "testremote" basesz = 1024 * 1024 keysizes = Command.TestRemote.keySizes basesz False prep getv = do @@ -225,17 +234,15 @@ testRemote = withResource newEmptyTMVarIO (const noop) $ \getv -> innewrepo $ do git_annex "init" [reponame, "--quiet"] @? "init failed" - createDirectory "remotedir" + preinitremote git_annex "initremote" - [ remotename + ([ remotename , "type=" ++ remotetype - , "directory=remotedir" - , "encryption=none" , "--quiet" - ] + ] ++ config) @? "init failed" r <- annexeval $ either error return - =<< Remote.byName' remotename + =<< Remote.byName' remotename unavailr <- annexeval $ Types.Remote.mkUnavailable r exportr <- annexeval $ Command.TestRemote.exportTreeVariant r ks <- annexeval $ mapM Command.TestRemote.randKey keysizes @@ -245,7 +252,8 @@ testRemote = withResource newEmptyTMVarIO (const noop) $ \getv -> go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks where runannex = inmainrepo . annexeval - mkrs = [descas (remotetype ++ " remote") (fst <$> v)] + mkrs = Command.TestRemote.remoteVariants mkr basesz False + mkr = descas (remotetype ++ " remote") (fst <$> v) mkunavailr = fst . snd <$> v mkexportr = fst . snd . snd <$> v mkks = map (\(sz, n) -> desckeysize sz (getk n)) diff --git a/doc/todo/test_testremote.mdwn b/doc/todo/test_testremote.mdwn index c45c823a21..6c1ca7a03e 100644 --- a/doc/todo/test_testremote.mdwn +++ b/doc/todo/test_testremote.mdwn @@ -10,3 +10,5 @@ that could then be added to the test suite's TestTree. (See [[bugs/testremote_failures_starting_with_aeca7c220]]) --[[Joey]] + +> [[done]] --[[Joey]]