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:
Joey Hess 2022-05-18 15:32:40 -04:00
parent 4ba7a97d8c
commit ebb76f0486
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 89 additions and 75 deletions

View file

@ -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
View file

@ -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 .

View file

@ -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

View file

@ -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

View file

@ -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]]