testremote in test is working

Not yet testing export, or remote variants, but it already adds several
hundred test cases, so big win.

Command/TestRemote.hs

@@ -88,26 +88,26 @@ start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
 	rs <- if Remote.readonly r'
 		then return [r']
 		else remoteVariants r' basesz fast
-	unavailrs  <- catMaybes <$> mapM Remote.mkUnavailable [r']
+	unavailr  <- Remote.mkUnavailable r'
 	exportr <- if Remote.readonly r'
 		then return Nothing
 		else exportTreeVariant r'
-	perform rs unavailrs exportr ks
+	perform rs unavailr exportr ks
   where
 	basesz = fromInteger $ sizeOption o
 
-remoteVariants :: Remote -> ByteSize -> Bool -> Annex [Remote]
+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] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform
+perform :: [Remote] -> Maybe Remote -> Maybe Remote -> [Key] -> CommandPerform
-perform rs unavailrs exportr ks = do
+perform rs 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)
-		(map (\r -> Described (descr r) (pure r)) unavailrs)
+		(pure unavailr)
 		(fmap pure exportr)
 		(map (\k -> Described (desck k) (pure k)) ks)
 	ok <- case tryIngredients [consoleTestReporter] mempty tests of
@@ -183,12 +183,12 @@ runTestCase stv a = do
 mkTestTrees
 	:: RunAnnex
 	-> [Described (Annex Remote)]
-	-> [Described (Annex Remote)]
+	-> Annex (Maybe Remote)
 	-> Maybe (Annex Remote)
 	-> [Described (Annex Key)]
 	-> [TestTree]
-mkTestTrees runannex mkrs mkunavailrs mkexportr mkks = concat $
+mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $
-	[ [ testGroup "unavailable remote" (testUnavailable runannex (getVal mkr) (getVal (Prelude.head mkks))) | mkr <- mkunavailrs ]
+	[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (Prelude.head mkks))) ]
 	, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- mkks, mkr <- mkrs ]
 	, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 mkks, mkk2 <- take 2 (reverse mkks) ]
 	]
@@ -328,7 +328,7 @@ testExportTree runannex (Just mkr) mkk1 mkk2 =
 		Nothing -> return True
 		Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory))
 
-testUnavailable :: RunAnnex -> Annex Remote -> Annex Key -> [TestTree]
+testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]
 testUnavailable runannex mkr mkk =
 	[ check (== Right False) "removeKey" $ \r k ->
 		Remote.removeKey r k
@@ -344,12 +344,15 @@ testUnavailable runannex mkr mkk =
 			Remote.retrieveKeyFileCheap r k (AssociatedFile Nothing) dest
 	]
   where
-	check checkval desc a = testCase desc $ do
+	check checkval desc a = testCase desc $ 
-		v <- runannex $ do
+		join $ runannex $ mkr >>= \case
-			r <- mkr
+			Just r -> do
-			k <- mkk
+				k <- mkk
-			either (Left  . show) Right <$> tryNonAsync (a r k)
+				v <- either (Left  . show) Right
-		checkval v  @? ("(got: " ++ show v ++ ")")
+					<$> tryNonAsync (a r k)
+				return $ checkval v
+					@? ("(got: " ++ show v ++ ")")
+			Nothing -> return noop
 
 cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
 cleanup rs ks ok

Test.hs

@@ -24,7 +24,7 @@ import Options.Applicative (switch, long, help, internal)
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy.UTF8 as BU8
 import System.Environment
-import Control.Concurrent.STM
+import Control.Concurrent.STM hiding (check)
 
 import Common
 import CmdLine.GitAnnex.Options
@@ -147,14 +147,16 @@ ingredients =
 
 tests :: Bool -> Bool -> TestOptions -> TestTree
 tests crippledfilesystem adjustedbranchok opts = 
-	testGroup "Tests" $ properties : testRemote :
+	testGroup "Tests" $ properties 
-		map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes
+		: withTestMode remotetestmode Nothing testRemote
+		: map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes
   where
 	testmodes = catMaybes
 		[ canadjust ("v8 adjusted unlocked branch", (testMode opts (RepoVersion 8)) { adjustedUnlockedBranch = True })
 		, unlesscrippled ("v8 unlocked", (testMode opts (RepoVersion 8)) { unlockedFiles = True })
 		, unlesscrippled ("v8 locked", testMode opts (RepoVersion 8))
 		]
+	remotetestmode = testMode opts (RepoVersion 8)
 	unlesscrippled v
 		| crippledfilesystem = Nothing
 		| otherwise = Just v
@@ -205,7 +207,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $
 		, Utility.Hash.props_macs_stable
 		]
 
-testRemote :: IO TestTree
+testRemote :: TestTree
 testRemote = withResource newEmptyTMVarIO (const noop) $ \getv -> 
 	testGroup "Remote Tests" $ concat
 		[ [testCase "init" (prep getv)]
@@ -215,6 +217,7 @@ testRemote = withResource newEmptyTMVarIO (const noop) $ \getv ->
 	reponame = "test repo"
 	remotename = "dir"
 	basesz = 1024 * 1024
+	keysizes = Command.TestRemote.keySizes basesz False
 	prep getv = do
 		d <- newmainrepodir
 		setmainrepodir d
@@ -232,23 +235,24 @@ testRemote = withResource newEmptyTMVarIO (const noop) $ \getv ->
 				@? "init failed"
 			r <- annexeval $ either error return 
 				=<< Remote.byName' remotename 
-			rs <- Command.TestRemote.remoteVariants r basesz False
+			unavailr <- annexeval $ Types.Remote.mkUnavailable r
-			unavailrs <- annexeval $ catMaybes
-				<$> mapM Types.Remote.mkUnavailable [r]
 			exportr <- annexeval $ Command.TestRemote.exportTreeVariant r
-			ks <- annexeval $ mapM Command.TestRemote.randKey $
+			ks <- annexeval $ mapM Command.TestRemote.randKey keysizes
-				Command.TestRemote.keySizes basesz False
 			v <- getv
 			liftIO $ atomically $ putTMVar v
-				(rs, (unavailrs, (descexportr, ks)))
+				(r, (unavailr, (exportr, ks)))
-	go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailrs mkexportr mkks
+	go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks
 	  where
 		runannex = inmainrepo . annexeval
-		mkrs = map descas "remote" (fst <$> v)
+		mkrs = [descas "remote" (fst <$> v)]
-		mkunavailrs = fst . snd <$> v
+		mkunavailr = fst . snd <$> v
-		mkexportr = fst . snd . snd <$> v
+		mkexportr = Nothing -- fst . snd . snd <$> v
-		mkks = snd . snd . snd <$> v
+		mkks = map (\(sz, n) -> desckeysize sz (getk n))
-		v = atomically . readTMVar =<< getv
+			(zip keysizes [0..])
+		getk n = fmap (!! n) (snd . snd . snd <$> v)
+		v = liftIO $ atomically . readTMVar =<< getv
+		descas = Command.TestRemote.Described
+		desckeysize sz = descas ("key size " ++ show sz)
 
 {- These tests set up the test environment, but also test some basic parts
  - of git-annex. They are always run before the unitTests. -}

Test/Framework.hs

@@ -417,17 +417,19 @@ testMode opts v = TestMode
 hasUnlockedFiles :: TestMode -> Bool
 hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m
 
-withTestMode :: TestMode -> TestTree -> TestTree -> TestTree
+withTestMode :: TestMode -> Maybe TestTree -> TestTree -> TestTree
-withTestMode testmode inittests = withResource prepare release . const
+withTestMode testmode minittests = withResource prepare release . const
   where
 	prepare = do
 		setTestMode testmode
 		setmainrepodir =<< newmainrepodir
-		case tryIngredients [consoleTestReporter] mempty inittests of
+		case minittests of
-			Nothing -> error "No tests found!?"
+			Just inittests ->
-			Just act -> unlessM act $
+				case tryIngredients [consoleTestReporter] mempty inittests of
-				error "init tests failed! cannot continue"
+					Nothing -> error "No tests found!?"
-		return ()
+					Just act -> unlessM act $
+						error "init tests failed! cannot continue"
+			Nothing -> return ()
 	release _ = noop
 
 setTestMode :: TestMode -> IO ()