avoid setEnv in test framework when tasty is running

setEnv is not thread safe and could cause a getEnv by another thread to
segfault, or perhaps other had behavior. This is particularly a problem
when using tasty, because tasty runs the test in a thread, and a getEnv
in another thread.

The use of top-level TMVars is ugly, but ok because only 1 test actually
runs at a time per process. Because it has to chdir into the test repo.

The setEnv that remains happens before tasty is running.

Sponsored-by: Dartmouth College's Datalad project

diff --git a/Test/Framework.hs b/Test/Framework.hs
index 94b06284cfcefff5e6f9ac61fb920c1ad4daea1e..13bfc87929910e21d9293bad8797cc72a237378e 100644 (file)
--- a/Test/Framework.hs
+++ b/Test/Framework.hs
@@ -24,6 +24,7 @@ import System.Environment (getArgs)
 import System.Console.Concurrent
 import System.Console.ANSI
 import GHC.Conc
+import System.IO.Unsafe (unsafePerformIO)
 
 import Common
 import Types.Test
@@ -260,14 +261,42 @@ ensuredir d = do
        e <- doesDirectoryExist d
        unless e $
                createDirectory d
-       
-{- Prevent global git configs from affecting the test suite. -}
-isolateGitConfig :: IO a -> IO a
-isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
+
+{- This is the only place in the test suite that can use setEnv.
+ - Using it elsewhere can conflict with tasty's use of getEnv, which can
+ - happen concurrently with a test case running, and would be a problem
+ - since setEnv is not thread safe. This is run before tasty. -}
+setTestEnv :: IO a -> IO a
+setTestEnv a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
        tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome)
+       {- Prevent global git configs from affecting the test suite. -}
        Utility.Env.Set.setEnv "HOME" tmphomeabs True
        Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
        Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
+       
+       -- Ensure that the same git-annex binary that is running
+       -- git-annex test is at the front of the PATH.
+       p <- Utility.Env.getEnvDefault "PATH" ""
+       pp <- Annex.Path.programPath
+       Utility.Env.Set.setEnv "PATH" (takeDirectory pp ++ [searchPathSeparator] ++ p) True
+       
+       -- Avoid git complaining if it cannot determine the user's
+       -- email address, or exploding if it doesn't know the user's name.
+       Utility.Env.Set.setEnv "GIT_AUTHOR_EMAIL" "test@example.com" True
+       Utility.Env.Set.setEnv "GIT_AUTHOR_NAME" "git-annex test" True
+       Utility.Env.Set.setEnv "GIT_COMMITTER_EMAIL" "test@example.com" True
+       Utility.Env.Set.setEnv "GIT_COMMITTER_NAME" "git-annex test" True
+       -- force gpg into batch mode for the tests
+       Utility.Env.Set.setEnv "GPG_BATCH" "1" True
+       -- Make git and git-annex access ssh remotes on the local
+       -- filesystem, without using ssh at all.
+       Utility.Env.Set.setEnv "GIT_SSH_COMMAND" "git-annex test --fakessh --" True
+       Utility.Env.Set.setEnv "GIT_ANNEX_USE_GIT_SSH" "1" True
+
+       -- Record top directory.
+       currdir <- getCurrentDirectory
+       Utility.Env.Set.setEnv "TOPDIR" currdir True
+       
        a
 
 removeDirectoryForCleanup :: FilePath -> IO ()
@@ -455,7 +484,7 @@ data TestMode = TestMode
        , adjustedUnlockedBranch :: Bool
        , annexVersion :: Types.RepoVersion.RepoVersion
        , keepFailures :: Bool
-       } deriving (Read, Show)
+       } deriving (Show)
 
 testMode :: TestOptions -> Types.RepoVersion.RepoVersion -> TestMode
 testMode opts v = TestMode
@@ -471,47 +500,32 @@ hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m
 withTestMode :: TestMode -> TestTree -> TestTree
 withTestMode testmode = withResource prepare release . const
   where
-       prepare = do
-               setTestMode testmode
-               setmainrepodir =<< newmainrepodir
+       prepare = setTestMode testmode
        release _ = noop
 
+{- The current test mode is stored here while a test is running.
+ -
+ - Only one test can be running at a time by a process; running a
+ - test also involves chdir into a test repository.
+ -}
+{-# NOINLINE currentTestMode #-}
+currentTestMode :: TMVar TestMode
+currentTestMode = unsafePerformIO newEmptyTMVarIO
+
+currentMainRepoDir :: TMVar FilePath
+currentMainRepoDir = unsafePerformIO newEmptyTMVarIO
+
 setTestMode :: TestMode -> IO ()
 setTestMode testmode = do
-       currdir <- getCurrentDirectory
-       p <- Utility.Env.getEnvDefault "PATH" ""
-       pp <- Annex.Path.programPath
-
-       mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)
-               -- Ensure that the same git-annex binary that is running
-               -- git-annex test is at the front of the PATH.
-               [ ("PATH", takeDirectory pp ++ [searchPathSeparator] ++ p)
-               , ("TOPDIR", currdir)
-               -- Avoid git complaining if it cannot determine the user's
-               -- email address, or exploding if it doesn't know the user's
-               -- name.
-               , ("GIT_AUTHOR_EMAIL", "test@example.com")
-               , ("GIT_AUTHOR_NAME", "git-annex test")
-               , ("GIT_COMMITTER_EMAIL", "test@example.com")
-               , ("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 --")
-               , ("GIT_ANNEX_USE_GIT_SSH", "1")
-               , ("TESTMODE", show testmode)
-               ]
-                               
-runFakeSsh :: [String] -> IO ()
-runFakeSsh ("-n":ps) = runFakeSsh ps
-runFakeSsh (_host:cmd:[]) =
-       withCreateProcess (shell cmd) $
-               \_ _ _ pid -> exitWith =<< waitForProcess pid
-runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
+       atomically $ do
+               _ <- tryTakeTMVar currentTestMode
+               putTMVar currentTestMode testmode
+       setmainrepodir =<< newmainrepodir
 
 getTestMode :: IO TestMode
-getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""
+getTestMode = atomically (tryReadTMVar currentTestMode) >>= \case
+       Just tm -> return tm
+       Nothing -> error "getTestMode without setTestMode"
 
 setupTestMode :: IO ()
 setupTestMode = do
@@ -528,12 +542,15 @@ changeToTopDir t = do
 tmpdir :: String
 tmpdir = ".t"
 
-mainrepodir :: IO FilePath
-mainrepodir = Utility.Env.getEnvDefault "MAINREPODIR"
-       (giveup "MAINREPODIR not set")
-
 setmainrepodir :: FilePath -> IO ()
-setmainrepodir d = Utility.Env.Set.setEnv "MAINREPODIR" d True
+setmainrepodir mrd = atomically $ do
+       _ <- tryTakeTMVar currentMainRepoDir
+       putTMVar currentMainRepoDir mrd
+
+mainrepodir :: IO FilePath
+mainrepodir = atomically (tryReadTMVar currentMainRepoDir) >>= \case
+       Just tm -> return tm
+       Nothing -> error "mainrepodir without setmainrepodir"
 
 newmainrepodir :: IO FilePath
 newmainrepodir = go (0 :: Int)
@@ -676,6 +693,13 @@ make_writeable d = void $
        Utility.Process.Transcript.processTranscript
                "chmod" ["-R", "u+w", d] Nothing
 
+runFakeSsh :: [String] -> IO ()
+runFakeSsh ("-n":ps) = runFakeSsh ps
+runFakeSsh (_host:cmd:[]) =
+       withCreateProcess (shell cmd) $
+               \_ _ _ pid -> exitWith =<< waitForProcess pid
+runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
+
 {- Tests each TestTree in parallel, and exits with succcess/failure.
  -
  - Tasty supports parallel tests, but this does not use it, because

diff --git a/doc/todo/test_suite_unsafe_use_of_setEnv.mdwn b/doc/todo/test_suite_unsafe_use_of_setEnv.mdwn
index 7327a30c9de2b3f43ec3181c49100a972eb33c2f..859d9ea4286501a6501bbcc160628c0b2456272b 100644 (file)
--- a/doc/todo/test_suite_unsafe_use_of_setEnv.mdwn
+++ b/doc/todo/test_suite_unsafe_use_of_setEnv.mdwn
@@ -19,4 +19,4 @@ There is also Utility.Gpg.testHarness, which sets GNUPGHOME. It seems that
 instead, every place that git-annex is run inside the gpg test harness
 would need to add GNUPGHOME to the environment of the git-annex process.
 
-> Fixed this part to not setEnv. --[[Joey]]
+> [[fixed|done]] --[[Joey]]