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
2022-05-18 15:32:40 -04:00 · 2022-05-18 15:32:40 -04:00 · ebb76f0486
commit ebb76f0486
parent 4ba7a97d8c
5 changed files with 89 additions and 75 deletions
--- a/Crypto.hs
+++ b/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 _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t
-decryptCipher cmd c (EncryptedCipher t variant _) =
-	mkCipher <$> Gpg.pipeStrict cmd params t
+decryptCipher cmd c cip = decryptCipher' cmd Nothing c cip
+
+decryptCipher' :: LensGpgEncParams c => Gpg.GpgCmd -> Maybe [(String, String)] -> c -> StorableCipher -> IO Cipher
+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
--- a/Test.hs
+++ b/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" ["create", borgdir++"::backup1", "."] (== True) "borg create"
+		testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) "borg init"
+		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
-			@? "test harness self-test failed"
-		void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do
+		void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ \environ -> 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_shouldfail "initremote" initps "initremote should not work when run twice in a row"
-			git_annex "enableremote" initps "enableremote"
-			git_annex "enableremote" initps "enableremote when run twice in a row"
-			git_annex "get" [annexedfile] "get of file"
+			git_annex' "initremote" initps (Just environ) "initremote"
+			git_annex_shouldfail' "initremote" initps (Just environ) "initremote should not work when run twice in a row"
+			git_annex' "enableremote" initps (Just environ) "enableremote"
+			git_annex' "enableremote" initps (Just environ) "enableremote when run twice in a row"
+			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 .
--- a/Test/Framework.hs
+++ b/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 command params expectedret faildesc = do
-	(transcript, ret) <- Utility.Process.Transcript.processTranscript command params Nothing
+testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> String -> Assertion
+testProcess command params environ expectedret faildesc = do
+	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' expectedret command params faildesc = do
+git_annex_shouldfail' :: String -> [String] -> Maybe [(String, String)] -> String -> Assertion
+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
--- a/Utility/Gpg.hs
+++ b/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 "--import", Param "-q"] $ unlines
+		_ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) []
+		_ <- 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 (Just Nothing) = stopgpgagent >> unsetEnv var
-	cleanup Nothing = stopgpgagent
+	cleanup Nothing = return ()
+	cleanup (Just environ) = stopgpgagent environ

 	-- 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") $
-		void $ boolSystem "gpgconf" [Param "--kill", Param "all"]
+	stopgpgagent environ = whenM (inSearchPath "gpgconf") $
+		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. -}
-testTestHarness :: FilePath -> GpgCmd -> IO Bool
-testTestHarness tmpdir cmd =
-	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
+checkEncryptionFile :: GpgCmd -> Maybe [(String, String)] -> FilePath -> Maybe KeyIds -> IO Bool
+checkEncryptionFile cmd environ filename keys =
+	checkGpgPackets cmd environ keys =<< readStrict' cmd params environ
  where
 	params = [Param "--list-packets", Param "--list-only", File filename]

-checkEncryptionStream :: GpgCmd -> String -> Maybe KeyIds -> IO Bool
-checkEncryptionStream cmd stream keys =
-	checkGpgPackets cmd keys =<< pipeStrict cmd params stream
+checkEncryptionStream :: GpgCmd -> Maybe [(String, String)] -> String -> Maybe KeyIds -> IO Bool
+checkEncryptionStream cmd environ stream keys =
+	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 cmd keys str = do
+checkGpgPackets :: GpgCmd -> Maybe [(String, String)] -> Maybe KeyIds -> String -> IO Bool
+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
--- a/doc/todo/test_suite_unsafe_use_of_setEnv.mdwn
+++ b/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]]