wip

This does not compile, and I hit a bad dead end. Wah.

CHANGELOG

@@ -43,6 +43,7 @@ git-annex (8.20200331) UNRELEASED; urgency=medium
     worked.
   * Avoid a test suite failure when the environment does not let gpg be
     tested due to eg, too long a path to the agent socket.
+  * test: Include testremote tests, run on a directory special remote.
 
  -- Joey Hess <id@joeyh.name>  Mon, 30 Mar 2020 15:58:34 -0400
 

Command/TestRemote.hs

@@ -87,9 +87,7 @@ start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
 		else r { Remote.readonly = True }
 	rs <- if Remote.readonly r'
 		then return [r']
-		else do
-			rs <- catMaybes <$> mapM (adjustChunkSize r') (chunkSizes basesz fast)
-			concat <$> mapM encryptionVariants rs
+		else remoteVariants r' basesz fast
 	unavailrs  <- catMaybes <$> mapM Remote.mkUnavailable [r']
 	exportr <- if Remote.readonly r'
 		then return Nothing
@@ -98,10 +96,15 @@ start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
   where
 	basesz = fromInteger $ sizeOption o
 
+remoteVariants :: Remote -> ByteSize -> 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 rs unavailrs exportr ks = do
 	st <- liftIO . newTVarIO =<< Annex.getState id
-	let tests = mkTestTree
+	let tests = testGroup "Remote Tests" $ mkTestTrees
 		(runTestCase st) 
 		(map (\r -> Described (descr r) (pure r)) rs)
 		(map (\r -> Described (descr r) (pure r)) unavailrs)
@@ -177,14 +180,14 @@ runTestCase stv a = do
 
 -- Note that the same remotes and keys should be produced each time
 -- the provided actions are called.
-mkTestTree
+mkTestTrees
 	:: RunAnnex
 	-> [Described (Annex Remote)]
 	-> [Described (Annex Remote)]
 	-> Maybe (Annex Remote)
 	-> [Described (Annex Key)]
-	-> TestTree
-mkTestTree runannex mkrs mkunavailrs mkexportr mkks = testGroup "Remote Tests" $ concat
+	-> [TestTree]
+mkTestTrees runannex mkrs mkunavailrs mkexportr mkks = concat $
 	[ [ testGroup "unavailable remote" (testUnavailable runannex (getVal mkr) (getVal (Prelude.head mkks))) | mkr <- mkunavailrs ]
 	, [ 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) ]

Test.hs

@@ -24,6 +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 Common
 import CmdLine.GitAnnex.Options
@@ -65,6 +66,7 @@ import qualified Annex.AdjustedBranch
 import qualified Annex.View
 import qualified Annex.View.ViewedFile
 import qualified Logs.View
+import qualified Command.TestRemote
 import qualified Utility.Path
 import qualified Utility.FileMode
 import qualified BuildInfo
@@ -145,7 +147,7 @@ ingredients =
 
 tests :: Bool -> Bool -> TestOptions -> TestTree
 tests crippledfilesystem adjustedbranchok opts = 
-	testGroup "Tests" $ properties :
+	testGroup "Tests" $ properties : testRemote :
 		map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes
   where
 	testmodes = catMaybes
@@ -203,6 +205,51 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $
 		, Utility.Hash.props_macs_stable
 		]
 
+testRemote :: IO TestTree
+testRemote = withResource newEmptyTMVarIO (const noop) $ \getv -> 
+	testGroup "Remote Tests" $ concat
+		[ [testCase "init" (prep getv)]
+		, go getv
+		]
+  where
+	reponame = "test repo"
+	remotename = "dir"
+	basesz = 1024 * 1024
+	prep getv = do
+		d <- newmainrepodir
+		setmainrepodir d
+		innewrepo $ do
+			git_annex "init" [reponame, "--quiet"]
+				@? "init failed"
+			createDirectory "remotedir"
+			git_annex "initremote"
+				[ remotename
+				, "type=directory"
+				, "directory=remotedir"
+				, "encryption=none"
+				, "--quiet"
+				]
+				@? "init failed"
+			r <- annexeval $ either error return 
+				=<< Remote.byName' remotename 
+			rs <- Command.TestRemote.remoteVariants r basesz False
+			unavailrs <- annexeval $ catMaybes
+				<$> mapM Types.Remote.mkUnavailable [r]
+			exportr <- annexeval $ Command.TestRemote.exportTreeVariant r
+			ks <- annexeval $ mapM Command.TestRemote.randKey $
+				Command.TestRemote.keySizes basesz False
+			v <- getv
+			liftIO $ atomically $ putTMVar v
+				(rs, (unavailrs, (descexportr, ks)))
+	go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailrs mkexportr mkks
+	  where
+		runannex = inmainrepo . annexeval
+		mkrs = map descas "remote" (fst <$> v)
+		mkunavailrs = fst . snd <$> v
+		mkexportr = fst . snd . snd <$> v
+		mkks = snd . snd . snd <$> v
+		v = atomically . readTMVar =<< getv
+
 {- These tests set up the test environment, but also test some basic parts
  - of git-annex. They are always run before the unitTests. -}
 initTests :: TestTree
@@ -281,7 +328,7 @@ unitTests note = testGroup ("Unit Tests " ++ note)
 	, testCase "addurl" test_addurl
 	]
 
--- this test case create the main repo
+-- this test case creates the main repo
 test_init :: Assertion
 test_init = innewrepo $ do
 	ver <- annexVersion <$> getTestMode

Test/Framework.hs

@@ -79,10 +79,10 @@ annexeval a = do
 		Annex.setOutput Types.Messages.QuietOutput
 		a `finally` Annex.Action.stopCoProcesses
 
-innewrepo :: Assertion -> Assertion
+innewrepo :: IO () -> IO ()
 innewrepo a = withgitrepo $ \r -> indir r a
 
-inmainrepo :: Assertion -> Assertion
+inmainrepo :: IO a -> IO a
 inmainrepo a = do
 	d <- mainrepodir
 	indir d a