From ebb76f0486030e1e6bae43b5f05d00d63a968681 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 May 2022 15:32:40 -0400 Subject: [PATCH] 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 | 16 ++-- Test.hs | 40 +++++----- Test/Framework.hs | 28 ++++--- Utility/Gpg.hs | 78 ++++++++++--------- doc/todo/test_suite_unsafe_use_of_setEnv.mdwn | 2 + 5 files changed, 89 insertions(+), 75 deletions(-) diff --git a/Crypto.hs b/Crypto.hs index 751c1cd256..6750284ee1 100644 --- 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 + - Copyright 2011-2022 Joey Hess - - 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 diff --git a/Test.hs b/Test.hs index a8d01bf6df..62e92e8d45 100644 --- 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 . diff --git a/Test/Framework.hs b/Test/Framework.hs index 3bb9c2d1d6..94b06284cf 100644 --- 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 diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 4128f387ce..5c217f0526 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -1,6 +1,6 @@ {- gpg interface - - - Copyright 2011 Joey Hess + - Copyright 2011-2022 Joey Hess - - 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 diff --git a/doc/todo/test_suite_unsafe_use_of_setEnv.mdwn b/doc/todo/test_suite_unsafe_use_of_setEnv.mdwn index 3d95a9e99b..7327a30c9d 100644 --- 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]]