avoid setEnv while testing gpg

setEnv is not thread safe and could cause a getEnv by another thread to
segfault, or perhaps other had behavior.

Sponsored-by: Dartmouth College's Datalad project

Crypto.hs

@@ -3,7 +3,7 @@
  - Currently using gpg; could later be modified to support different
  - crypto backends if neccessary.
  -
- - Copyright 2011-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -22,7 +22,8 @@ module Crypto (
 	genSharedCipher,
 	genSharedPubKeyCipher,
 	updateCipherKeyIds,
-	decryptCipher,		
+	decryptCipher,
+	decryptCipher',
 	encryptKey,
 	isEncKey,
 	feedFile,
@@ -147,10 +148,13 @@ encryptCipher cmd c cip variant (KeyIds ks) = do
 
 {- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
 decryptCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> StorableCipher -> IO Cipher
-decryptCipher _ _ (SharedCipher t) = return $ Cipher t
+decryptCipher cmd c cip = decryptCipher' cmd Nothing c cip
-decryptCipher _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t
+
-decryptCipher cmd c (EncryptedCipher t variant _) =
+decryptCipher' :: LensGpgEncParams c => Gpg.GpgCmd -> Maybe [(String, String)] -> c -> StorableCipher -> IO Cipher
-	mkCipher <$> Gpg.pipeStrict cmd params t
+decryptCipher' _ _ _ (SharedCipher t) = return $ Cipher t
+decryptCipher' _ _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t
+decryptCipher' cmd environ c (EncryptedCipher t variant _) =
+	mkCipher <$> Gpg.pipeStrict' cmd params environ t
   where
 	mkCipher = case variant of
 		Hybrid -> Cipher

Test.hs

@@ -1643,7 +1643,7 @@ test_uninit = intmpclonerepo $ do
 	git_annex "get" [] "get"
 	annexed_present annexedfile
 	-- any exit status is accepted; does abnormal exit
-	git_annex' (const True) "uninit" [] "uninit"
+	git_annex'' (const True) "uninit" [] Nothing "uninit"
 	checkregularfile annexedfile
 	doesDirectoryExist ".git" @? ".git vanished in uninit"
 
@@ -1758,8 +1758,8 @@ test_borg_remote = when BuildInfo.borg $ do
 	borgdirparent <- fromRawFilePath <$> (absPath . toRawFilePath =<< tmprepodir)
 	let borgdir = borgdirparent </> "borgrepo"
 	intmpclonerepo $ do
-		testProcess "borg" ["init", borgdir, "-e", "none"] (== True) "borg init"
+		testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) "borg init"
-		testProcess "borg" ["create", borgdir++"::backup1", "."] (== True) "borg create"
+		testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) "borg create"
 
 		git_annex "initremote" (words $ "borg type=borg borgrepo="++borgdir) "initremote"
 		git_annex "sync" ["borg"] "sync borg"
@@ -1769,7 +1769,7 @@ test_borg_remote = when BuildInfo.borg $ do
 		annexed_present annexedfile
 		git_annex_expectoutput "find" ["--in=borg"] []
 		
-		testProcess "borg" ["create", borgdir++"::backup2", "."] (== True) "borg create"
+		testProcess "borg" ["create", borgdir++"::backup2", "."] Nothing (== True) "borg create"
 		git_annex "sync" ["borg"] "sync borg after getting file"
 		git_annex_expectoutput "find" ["--in=borg"] [annexedfile]
 
@@ -1808,9 +1808,7 @@ test_crypto = do
 		let gpgtmp = if length relgpgtmp < length absgpgtmp
 			then relgpgtmp 
 			else absgpgtmp
-		Utility.Gpg.testTestHarness gpgtmp gpgcmd
+		void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ \environ -> do
-			@? "test harness self-test failed"
-		void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do
 			createDirectory "dir"
 			let initps =
 				[ "foo"
@@ -1821,13 +1819,13 @@ test_crypto = do
 				] ++ if scheme `elem` ["hybrid","pubkey"]
 					then ["keyid=" ++ Utility.Gpg.testKeyId]
 					else []
-			git_annex "initremote" initps "initremote"
+			git_annex' "initremote" initps (Just environ) "initremote"
-			git_annex_shouldfail "initremote" initps "initremote should not work when run twice in a row"
+			git_annex_shouldfail' "initremote" initps (Just environ) "initremote should not work when run twice in a row"
-			git_annex "enableremote" initps "enableremote"
+			git_annex' "enableremote" initps (Just environ) "enableremote"
-			git_annex "enableremote" initps "enableremote when run twice in a row"
+			git_annex' "enableremote" initps (Just environ) "enableremote when run twice in a row"
-			git_annex "get" [annexedfile] "get of file"
+			git_annex' "get" [annexedfile] (Just environ) "get of file"
 			annexed_present annexedfile
-			git_annex "copy" [annexedfile, "--to", "foo"] "copy --to encrypted remote"
+			git_annex' "copy" [annexedfile, "--to", "foo"] (Just environ) "copy --to encrypted remote"
 			(c,k) <- annexeval $ do
 				uuid <- Remote.nameToUUID "foo"
 				rs <- Logs.Remote.readRemoteLog
@@ -1836,18 +1834,18 @@ test_crypto = do
 			let key = if scheme `elem` ["hybrid","pubkey"]
 					then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]
 					else Nothing
-			testEncryptedRemote scheme key c [k] @? "invalid crypto setup"
+			testEncryptedRemote environ scheme key c [k] @? "invalid crypto setup"
 	
 			annexed_present annexedfile
-			git_annex "drop" [annexedfile, "--numcopies=2"] "drop"
+			git_annex' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop"
 			annexed_notpresent annexedfile
-			git_annex "move" [annexedfile, "--from", "foo"] "move --from encrypted remote"
+			git_annex' "move" [annexedfile, "--from", "foo"] (Just environ) "move --from encrypted remote"
 			annexed_present annexedfile
-			git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] "drop should not be allowed with numcopies=2"
+			git_annex_shouldfail' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop should not be allowed with numcopies=2"
 			annexed_present annexedfile
 	{- Ensure the configuration complies with the encryption scheme, and
 	 - that all keys are encrypted properly for the given directory remote. -}
-	testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of
+	testEncryptedRemote environ scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of
 		Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks ->
 			checkKeys cip Nothing
 		Just cip@(Crypto.EncryptedCipher encipher v ks')
@@ -1860,18 +1858,18 @@ test_crypto = do
 		keysMatch (Utility.Gpg.KeyIds ks') =
 			maybe False (\(Utility.Gpg.KeyIds ks2) ->
 					sort (nub ks2) == sort (nub ks')) ks
-		checkCipher encipher = Utility.Gpg.checkEncryptionStream gpgcmd encipher . Just
+		checkCipher encipher = Utility.Gpg.checkEncryptionStream gpgcmd (Just environ) encipher . Just
 		checkScheme Types.Crypto.Hybrid = scheme == "hybrid"
 		checkScheme Types.Crypto.PubKey = scheme == "pubkey"
 		checkKeys cip mvariant = do
 			dummycfg <- Types.GitConfig.dummyRemoteGitConfig
 			let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg)
-			cipher <- Crypto.decryptCipher gpgcmd encparams cip
+			cipher <- Crypto.decryptCipher' gpgcmd (Just environ) encparams cip
 			files <- filterM doesFileExist $
 				map ("dir" </>) $ concatMap (serializeKeys cipher) keys
 			return (not $ null files) <&&> allM (checkFile mvariant) files
 		checkFile mvariant filename =
-			Utility.Gpg.checkEncryptionFile gpgcmd filename $
+			Utility.Gpg.checkEncryptionFile gpgcmd (Just environ) filename $
 				if mvariant == Just Types.Crypto.PubKey then ks else Nothing
 		serializeKeys cipher = map fromRawFilePath . 
 			Annex.Locations.keyPaths .

Test/Framework.hs

@@ -64,32 +64,40 @@ import qualified Command.Uninit
 
 -- Run a process. The output and stderr is captured, and is only
 -- displayed if the process does not return the expected value.
-testProcess :: String -> [String] -> (Bool -> Bool) -> String -> Assertion
+testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> String -> Assertion
-testProcess command params expectedret faildesc = do
+testProcess command params environ expectedret faildesc = do
-	(transcript, ret) <- Utility.Process.Transcript.processTranscript command params Nothing
+	let p = (proc command params) { env = environ }
+	(transcript, ret) <- Utility.Process.Transcript.processTranscript' p Nothing
 	(expectedret ret) @? (faildesc ++ " failed (transcript follows)\n" ++ transcript)
 
 -- Run git. (Do not use to run git-annex as the one being tested
 -- may not be in path.)
 git :: String -> [String] -> String -> Assertion
-git command params = testProcess "git" (command:params) (== True)
+git command params = testProcess "git" (command:params) Nothing (== True)
 
 -- For when git is expected to fail.
 git_shouldfail :: String -> [String] -> String -> Assertion
-git_shouldfail command params = testProcess "git" (command:params) (== False)
+git_shouldfail command params = testProcess "git" (command:params) Nothing (== False)
 
 -- Run git-annex.
 git_annex :: String -> [String] -> String -> Assertion
-git_annex = git_annex' (== True)
+git_annex command params faildesc = git_annex' command params Nothing faildesc
+
+-- Runs git-annex with some environment.
+git_annex' :: String -> [String] -> Maybe [(String, String)] -> String -> Assertion
+git_annex' = git_annex'' (== True)
 
 -- For when git-annex is expected to fail.
 git_annex_shouldfail :: String -> [String] -> String -> Assertion
-git_annex_shouldfail = git_annex' (== False)
+git_annex_shouldfail command params faildesc = git_annex_shouldfail' command params Nothing faildesc
 
-git_annex' :: (Bool -> Bool) -> String -> [String] -> String -> Assertion
+git_annex_shouldfail' :: String -> [String] -> Maybe [(String, String)] -> String -> Assertion
-git_annex' expectedret command params faildesc = do
+git_annex_shouldfail' = git_annex'' (== False)
+
+git_annex'' :: (Bool -> Bool) -> String -> [String] -> Maybe [(String, String)] -> String -> Assertion
+git_annex'' expectedret command params environ faildesc = do
 	pp <- Annex.Path.programPath
-	testProcess pp (command:params) expectedret faildesc
+	testProcess pp (command:params) environ expectedret faildesc
 
 {- Runs git-annex and returns its standard output. -}
 git_annex_output :: String -> [String] -> IO String

Utility/Gpg.hs

@@ -1,6 +1,6 @@
 {- gpg interface
  -
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -16,6 +16,7 @@ module Utility.Gpg (
 	pkEncTo,
 	stdEncryptionParams,
 	pipeStrict,
+	pipeStrict',
 	feedRead,
 	feedRead',
 	findPubKeys,
@@ -28,7 +29,6 @@ module Utility.Gpg (
 	testKeyId,
 #ifndef mingw32_HOST_OS
 	testHarness,
-	testTestHarness,
 	checkEncryptionFile,
 	checkEncryptionStream,
 #endif
@@ -40,7 +40,6 @@ import qualified BuildInfo
 import System.Posix.Types
 import System.Posix.IO
 import Utility.Env
-import Utility.Env.Set
 import Utility.FileMode
 #else
 import Utility.Tmp
@@ -110,10 +109,15 @@ stdEncryptionParams symmetric = enc symmetric ++
 
 {- Runs gpg with some params and returns its stdout, strictly. -}
 readStrict :: GpgCmd -> [CommandParam] -> IO String
-readStrict (GpgCmd cmd) params = do
+readStrict c p = readStrict' c p Nothing
+
+readStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> IO String
+readStrict' (GpgCmd cmd) params environ = do
 	params' <- stdParams params
 	let p = (proc cmd params')
-		{ std_out = CreatePipe }
+		{ std_out = CreatePipe
+		, env = environ
+		}
 	withCreateProcess p (go p)
   where
 	go p _ (Just hout) _ pid = do
@@ -124,11 +128,15 @@ readStrict (GpgCmd cmd) params = do
 {- Runs gpg, piping an input value to it, and returning its stdout,
  - strictly. -}
 pipeStrict :: GpgCmd -> [CommandParam] -> String -> IO String
-pipeStrict (GpgCmd cmd) params input = do
+pipeStrict c p i = pipeStrict' c p Nothing i
+
+pipeStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> String -> IO String
+pipeStrict' (GpgCmd cmd) params environ input = do
 	params' <- stdParams params
 	let p = (proc cmd params')
 		{ std_in = CreatePipe
 		, std_out = CreatePipe
+		, env = environ
 		}
 	withCreateProcess p (go p)
   where
@@ -208,11 +216,14 @@ feedRead' (GpgCmd cmd) params feeder reader = do
  - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of
  - GnuPG's manpage.) -}
 findPubKeys :: GpgCmd -> String -> IO KeyIds
-findPubKeys cmd for
+findPubKeys cmd = findPubKeys' cmd Nothing
+
+findPubKeys' :: GpgCmd -> Maybe [(String, String)] -> String -> IO KeyIds
+findPubKeys' cmd environ for
 	-- pass forced subkey through as-is rather than
 	-- looking up the master key.
 	| isForcedSubKey for = return $ KeyIds [for]
-	| otherwise = KeyIds . parse . lines <$> readStrict cmd params
+	| otherwise = KeyIds . parse . lines <$> readStrict' cmd params environ
   where
 	params = [Param "--with-colons", Param "--list-public-keys", Param for]
 	parse = mapMaybe (keyIdField . splitc ':')
@@ -410,7 +421,7 @@ keyBlock public ls = unlines
  - perhaps related to the agent socket), the action is not run, and Nothing
  - is returned.
  -}
-testHarness :: FilePath -> GpgCmd -> IO a -> IO (Maybe a)
+testHarness :: FilePath -> GpgCmd -> ([(String, String)] -> IO a) -> IO (Maybe a)
 testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd))
 	( bracket (eitherToMaybe <$> tryNonAsync setup) cleanup go
 	, return Nothing
@@ -419,30 +430,30 @@ testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd))
 	var = "GNUPGHOME"
 
 	setup = do
-		orig <- getEnv var
 		subdir <- makenewdir (1 :: Integer)
+		origenviron <- getEnvironment
+		let environ = addEntry var subdir origenviron
 		-- gpg is picky about permissions on its home dir
 		liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $
 			removeModes $ otherGroupModes
-		setEnv var subdir True
 		-- For some reason, recent gpg needs a trustdb to be set up.
-		_ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] []
+		_ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) []
-		_ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines
+		_ <- pipeStrict' cmd [Param "--import", Param "-q"] (Just environ) $ unlines
 			[testSecretKey, testKey]
-		return orig
+		return environ
 		
-	cleanup (Just (Just v)) = stopgpgagent >> setEnv var v True
+	cleanup Nothing = return ()
-	cleanup (Just Nothing) = stopgpgagent >> unsetEnv var
+	cleanup (Just environ) = stopgpgagent environ
-	cleanup Nothing = stopgpgagent
 
 	-- Recent versions of gpg automatically start gpg-agent, or perhaps
 	-- other daemons. Stop them when done. This only affects
 	-- daemons started for the GNUPGHOME that was used.
 	-- Older gpg may not support this, so ignore failure.
-	stopgpgagent = whenM (inSearchPath "gpgconf") $
+	stopgpgagent environ = whenM (inSearchPath "gpgconf") $
-		void $ boolSystem "gpgconf" [Param "--kill", Param "all"]
+		void $ boolSystemEnv "gpgconf" [Param "--kill", Param "all"]
+			(Just environ) 
 
-	go (Just _) = Just <$> a
+	go (Just environ) = Just <$> a environ
 	go Nothing = return Nothing
 
         makenewdir n = do
@@ -451,24 +462,15 @@ testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd))
 			createDirectory subdir
 			return subdir
 
-{- Tests the test harness. -}
+checkEncryptionFile :: GpgCmd -> Maybe [(String, String)] -> FilePath -> Maybe KeyIds -> IO Bool
-testTestHarness :: FilePath -> GpgCmd -> IO Bool
+checkEncryptionFile cmd environ filename keys =
-testTestHarness tmpdir cmd =
+	checkGpgPackets cmd environ keys =<< readStrict' cmd params environ
-	testHarness tmpdir cmd (findPubKeys cmd testKeyId) >>= \case
-		Nothing -> do
-			hPutStrLn stderr "unable to test gpg, setting up the test harness did not succeed"
-			return True
-		Just keys -> return $ KeyIds [testKeyId] == keys
-
-checkEncryptionFile :: GpgCmd -> FilePath -> Maybe KeyIds -> IO Bool
-checkEncryptionFile cmd filename keys =
-	checkGpgPackets cmd keys =<< readStrict cmd params
   where
 	params = [Param "--list-packets", Param "--list-only", File filename]
 
-checkEncryptionStream :: GpgCmd -> String -> Maybe KeyIds -> IO Bool
+checkEncryptionStream :: GpgCmd -> Maybe [(String, String)] -> String -> Maybe KeyIds -> IO Bool
-checkEncryptionStream cmd stream keys =
+checkEncryptionStream cmd environ stream keys =
-	checkGpgPackets cmd keys =<< pipeStrict cmd params stream
+	checkGpgPackets cmd environ keys =<< pipeStrict' cmd params environ stream
   where
 	params = [Param "--list-packets", Param "--list-only"]
 
@@ -476,8 +478,8 @@ checkEncryptionStream cmd stream keys =
  - symmetrically encrypted (keys is Nothing), or encrypted to some
  - public key(s).
  - /!\ The key needs to be in the keyring! -}
-checkGpgPackets :: GpgCmd -> Maybe KeyIds -> String -> IO Bool
+checkGpgPackets :: GpgCmd -> Maybe [(String, String)] -> Maybe KeyIds -> String -> IO Bool
-checkGpgPackets cmd keys str = do
+checkGpgPackets cmd environ keys str = do
 	let (asym,sym) = partition (pubkeyEncPacket `isPrefixOf`) $
 			filter (\l' -> pubkeyEncPacket `isPrefixOf` l' ||
 				symkeyEncPacket `isPrefixOf` l') $
@@ -488,7 +490,7 @@ checkGpgPackets cmd keys str = do
 		(Just (KeyIds ks), ls, []) -> do
 			-- Find the master key associated with the
 			-- encryption subkey.
-			ks' <- concat <$> mapM (keyIds <$$> findPubKeys cmd)
+			ks' <- concat <$> mapM (keyIds <$$> findPubKeys' cmd environ)
 					[ k | k:"keyid":_ <- map (reverse . words) ls ]
 			return $ sort (nub ks) == sort (nub ks')
 		_ -> return False

doc/todo/test_suite_unsafe_use_of_setEnv.mdwn

@@ -18,3 +18,5 @@ toplevel MVar would be ok, since tests don't run concurrently?
 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]]