From 9a79dc9ec02a430c21ac720d7c6a4ee11a3edcdd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 17 Mar 2017 19:13:52 -0400 Subject: test suite infra for testing mocked ssh remotes This commit was supported by the NSF-funded DataLad project. --- Makefile | 9 +++++--- Test.hs | 71 +++++++++++++++++++++++++++++++++++++++++++++-------------- Types/Test.hs | 9 ++++++-- 3 files changed, 68 insertions(+), 21 deletions(-) diff --git a/Makefile b/Makefile index 47b0a9ccc..ed2d92170 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -all=git-annex mans docs +all=git-annex git-annex-shell mans docs # set to "./Setup" if you lack a cabal program. Or can be set to "stack" BUILDER?=cabal @@ -29,12 +29,15 @@ git-annex: tmp/configure-stamp else \ ln -sf dist/build/git-annex/git-annex git-annex; \ fi - # Work around https://github.com/haskell/cabal/issues/3524 - # when not linked dynamically to haskell libs +# Work around https://github.com/haskell/cabal/issues/3524 +# when not linked dynamically to haskell libs @if ! ldd git-annex | grep -q libHS; then \ chrpath -d git-annex || echo "** unable to chrpath git-annex; it will be a little bit slower than necessary"; \ fi +git-annex-shell: git-annex + ln -sf git-annex git-annex-shell + # These are not built normally. git-union-merge.1: doc/git-union-merge.mdwn ./Build/mdwn2man git-union-merge 1 doc/git-union-merge.mdwn > git-union-merge.1 diff --git a/Test.hs b/Test.hs index 7ef0cb5f0..11fac2ea2 100644 --- a/Test.hs +++ b/Test.hs @@ -1,6 +1,6 @@ {- git-annex test suite - - - Copyright 2010-2016 Joey Hess + - Copyright 2010-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -29,13 +29,14 @@ import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.Tasty.Ingredients.Rerun -import Options.Applicative (switch, long, help) +import Options.Applicative (switch, long, help, internal) import qualified Data.Map as M import qualified Data.Aeson import qualified Data.ByteString.Lazy.UTF8 as BU8 import Common +import CmdLine.GitAnnex.Options import qualified Utility.SafeCommand import qualified Annex @@ -112,21 +113,31 @@ optParser = TestOptions <*> switch ( long "keep-failures" <> help "preserve repositories on test failure" - ) + ) + <*> switch + ( long "fakessh" + <> internal + ) + <*> cmdParams "non-options are for internal use only" runner :: Maybe (TestOptions -> IO ()) -runner = Just $ \opts -> isolateGitConfig $ do - ensuretmpdir - crippledfilesystem <- Annex.Init.probeCrippledFileSystem' tmpdir - case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of - Nothing -> error "No tests found!?" - Just act -> ifM act - ( exitSuccess - , do - putStrLn " (This could be due to a bug in git-annex, or an incompatibility" - putStrLn " with utilities, such as git, installed on this system.)" - exitFailure - ) +runner = Just go + where + go opts + | fakeSsh opts = runFakeSsh (internalData opts) + | otherwise = runtests opts + runtests opts = isolateGitConfig $ do + ensuretmpdir + crippledfilesystem <- Annex.Init.probeCrippledFileSystem' tmpdir + case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of + Nothing -> error "No tests found!?" + Just act -> ifM act + ( exitSuccess + , do + putStrLn " (This could be due to a bug in git-annex, or an incompatibility" + putStrLn " with utilities, such as git, installed on this system.)" + exitFailure + ) ingredients :: [Ingredient] ingredients = @@ -211,6 +222,7 @@ unitTests note = testGroup ("Unit Tests " ++ note) , testCase "drop (with remote)" test_drop_withremote , testCase "drop (untrusted remote)" test_drop_untrustedremote , testCase "get" test_get + , testCase "get (from ssh remote)" test_get_ssh_remote , testCase "move" test_move , testCase "copy" test_copy , testCase "lock" test_lock @@ -458,7 +470,13 @@ test_drop_untrustedremote = intmpclonerepo $ do inmainrepo $ annexed_present annexedfile test_get :: Assertion -test_get = intmpclonerepo $ do +test_get = test_get' intmpclonerepo + +test_get_ssh_remote :: Assertion +test_get_ssh_remote = test_get' (with_ssh_origin intmpclonerepo) + +test_get' :: (Assertion -> Assertion) -> Assertion +test_get' setup = setup $ do inmainrepo $ annexed_present annexedfile annexed_notpresent annexedfile git_annex "get" [annexedfile] @? "get of file failed" @@ -1740,6 +1758,16 @@ innewrepo a = withgitrepo $ \r -> indir r a inmainrepo :: Assertion -> Assertion inmainrepo = indir mainrepodir +with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) +with_ssh_origin cloner a = cloner $ do + origindir <- absPath + =<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null") + let originurl = "localhost:" ++ origindir + boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" + a + where + config = "remote.origin.url" + intmpclonerepo :: Assertion -> Assertion intmpclonerepo a = withtmpclonerepo $ \r -> indir r a @@ -2072,9 +2100,20 @@ setTestMode testmode = do , ("GIT_COMMITTER_NAME", "git-annex test") -- force gpg into batch mode for the tests , ("GPG_BATCH", "1") + -- Make git and git-annex access ssh remotes on the local + -- filesystem, without using ssh at all. + , ("GIT_SSH_COMMAND", "git-annex test --fakessh --") , ("TESTMODE", show testmode) ] +runFakeSsh :: [String] -> IO () +runFakeSsh ("-n":ps) = runFakeSsh ps +runFakeSsh (_host:cmd:[]) = do + let p = shell cmd + (_, _, _, pid) <- createProcess p + forceSuccessProcess p pid +runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps + getTestMode :: IO TestMode getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" "" diff --git a/Types/Test.hs b/Types/Test.hs index eadf6d29a..66f263c2e 100644 --- a/Types/Test.hs +++ b/Types/Test.hs @@ -1,6 +1,6 @@ {- git-annex test data types. - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,19 +13,24 @@ module Types.Test where import Test.Tasty.Options import Data.Monoid import Prelude +import Types.Command #endif #ifdef WITH_TESTSUITE data TestOptions = TestOptions { tastyOptionSet :: OptionSet , keepFailuresOption :: Bool + , fakeSsh :: Bool + , internalData :: CmdParams } instance Monoid TestOptions where - mempty = TestOptions mempty False + mempty = TestOptions mempty False False mempty mappend a b = TestOptions (tastyOptionSet a <> tastyOptionSet b) (keepFailuresOption a || keepFailuresOption b) + (fakeSsh a || fakeSsh b) + (internalData a <> internalData b) #else type TestOptions = () -- cgit v1.2.3