summaryrefslogtreecommitdiff
path: root/Test.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-01-06 13:44:12 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-01-06 13:44:12 -0400
commit82a27da0157ce3fc78ab917b6d9d26486ed7bb8c (patch)
tree9d9de1506ffb0aa91a16cb28866d4806ab37bec5 /Test.hs
parentf906cddf91577c53600a60e4cfbfa3c1fe25d1ab (diff)
test: Added --keep-failures option.
Diffstat (limited to 'Test.hs')
-rw-r--r--Test.hs55
1 files changed, 37 insertions, 18 deletions
diff --git a/Test.hs b/Test.hs
index 499ce80da..fdb1404cb 100644
--- a/Test.hs
+++ b/Test.hs
@@ -9,6 +9,7 @@
module Test where
+import Types.Test
import Options.Applicative.Types
#ifndef WITH_TESTSUITE
@@ -24,11 +25,11 @@ runner = Nothing
#else
import Test.Tasty
-import Test.Tasty.Options
import Test.Tasty.Runners
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Test.Tasty.Ingredients.Rerun
+import Options.Applicative (switch, long, help)
import qualified Data.Map as M
import qualified Text.JSON
@@ -99,11 +100,16 @@ import qualified Types.Crypto
import qualified Utility.Gpg
#endif
-optParser :: Parser OptionSet
-optParser = suiteOptionParser ingredients tests
+optParser :: Parser TestOptions
+optParser = TestOptions
+ <$> suiteOptionParser ingredients (tests mempty)
+ <*> switch
+ ( long "keep-failures"
+ <> help "preserve repositories on test failure"
+ )
-runner :: Maybe (OptionSet -> IO ())
-runner = Just $ \opts -> case tryIngredients ingredients opts tests of
+runner :: Maybe (TestOptions -> IO ())
+runner = Just $ \opts -> case tryIngredients ingredients (tastyOptionSet opts) (tests opts) of
Nothing -> error "No tests found!?"
Just act -> ifM act
( exitSuccess
@@ -119,17 +125,17 @@ ingredients =
, rerunningTests [consoleTestReporter]
]
-tests :: TestTree
-tests = testGroup "Tests" $ properties :
+tests :: TestOptions -> TestTree
+tests opts = testGroup "Tests" $ properties :
map (\(d, te) -> withTestMode te (unitTests d)) testmodes
where
testmodes =
- -- [ ("v6 unlocked", (testMode "6") { unlockedFiles = True })
- [ ("v6 locked", testMode "6")
- , ("v5", testMode "5")
+ [ ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })
+ , ("v6 locked", testMode opts "6")
+ , ("v5", testMode opts "5")
#ifndef mingw32_HOST_OS
-- Windows will only use direct mode, so don't test twice.
- , ("v5 direct", (testMode "5") { forceDirect = True })
+ , ("v5 direct", (testMode opts "5") { forceDirect = True })
#endif
]
@@ -1611,7 +1617,17 @@ withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig
withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion
withtmpclonerepo' cfg a = do
dir <- tmprepodir
- bracket (clonerepo mainrepodir dir cfg) cleanup a
+ clone <- clonerepo mainrepodir dir cfg
+ r <- tryNonAsync (a clone)
+ case r of
+ Right () -> cleanup clone
+ Left e -> do
+ ifM (keepFailures <$> getTestMode)
+ ( putStrLn $ "** Preserving repo for failure analysis in " ++ clone
+ , cleanup clone
+ )
+ throwM e
+
disconnectOrigin :: Assertion
disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm"
@@ -1839,13 +1855,15 @@ data TestMode = TestMode
{ forceDirect :: Bool
, unlockedFiles :: Bool
, annexVersion :: Annex.Version.Version
+ , keepFailures :: Bool
} deriving (Read, Show)
-testMode :: Annex.Version.Version -> TestMode
-testMode v = TestMode
+testMode :: TestOptions -> Annex.Version.Version -> TestMode
+testMode opts v = TestMode
{ forceDirect = False
, unlockedFiles = False
, annexVersion = v
+ , keepFailures = keepFailuresOption opts
}
withTestMode :: TestMode -> TestTree -> TestTree
@@ -1858,13 +1876,14 @@ withTestMode testmode = withResource prepare release . const
Just act -> unlessM act $
error "init tests failed! cannot continue"
return ()
- release _ = cleanup' True tmpdir
+ release _
+ | keepFailures testmode = void $ tryIO $ do
+ cleanup' True mainrepodir
+ removeDirectory tmpdir
+ | otherwise = cleanup' True tmpdir
setTestMode :: TestMode -> IO ()
setTestMode testmode = do
- whenM (doesDirectoryExist tmpdir) $
- error $ "The temporary directory " ++ tmpdir ++ " already exists; cannot run test suite."
-
currdir <- getCurrentDirectory
p <- Utility.Env.getEnvDefault "PATH" ""