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]]