From d7db481471d72b5e1bd876d21b208ff97ec741ae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 29 Apr 2020 15:48:09 -0400 Subject: [PATCH] wip This does not compile, and I hit a bad dead end. Wah. --- CHANGELOG | 1 + Command/TestRemote.hs | 17 +++++++++------ Test.hs | 51 +++++++++++++++++++++++++++++++++++++++++-- Test/Framework.hs | 4 ++-- 4 files changed, 62 insertions(+), 11 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index c13d1ad023..6d34599763 100644 --- a/CHANGELOG +++ b/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 Mon, 30 Mar 2020 15:58:34 -0400 diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index d4ad6eda52..f61bfdc88b 100644 --- a/Command/TestRemote.hs +++ b/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) ] diff --git a/Test.hs b/Test.hs index 3d060163cc..bc8d69844f 100644 --- a/Test.hs +++ b/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 diff --git a/Test/Framework.hs b/Test/Framework.hs index 2e591ed43a..7f48b666a5 100644 --- a/Test/Framework.hs +++ b/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 -- 2.30.2