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…
Reference in a new issue