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
This commit is contained in:
		
					parent
					
						
							
								4ba7a97d8c
							
						
					
				
			
			
				commit
				
					
						ebb76f0486
					
				
			
		
					 5 changed files with 89 additions and 75 deletions
				
			
		
							
								
								
									
										14
									
								
								Crypto.hs
									
										
									
									
									
								
							
							
						
						
									
										14
									
								
								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.
 | 
			
		||||
 -}
 | 
			
		||||
| 
						 | 
				
			
			@ -23,6 +23,7 @@ module Crypto (
 | 
			
		|||
	genSharedPubKeyCipher,
 | 
			
		||||
	updateCipherKeyIds,
 | 
			
		||||
	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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										40
									
								
								Test.hs
									
										
									
									
									
								
							
							
						
						
									
										40
									
								
								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 .
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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]]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue