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

diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs
index d538b5ed5ad77e106ecf0bdc0a324f3f70db79e3..df4606b586a5b9d558fb369df08e13bc2d42fb2f 100644 (file)
--- 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 a257e2cb0a64c3a829426cba02e79782287da274..7f79fafdd69ea12192b62670b07e61827637350b 100644 (file)
--- 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 c45c823a218cf5216ee8860caf88ad609b20a511..6c1ca7a03eb400bb097a206d632b8b063b2588f8 100644 (file)
--- 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]]