support gpg.program
When gpg.program is configured, it's used to get the command to run for gpg. Useful on systems that have only a gpg2 command or want to use it instead of the gpg command.
This commit is contained in:
Joey Hess
parent
cf85370ade
commit
0390efae8c
17 changed files with 173 additions and 113 deletions
|
|
@ -30,10 +30,16 @@ type KeyId = String
|
|||
newtype KeyIds = KeyIds { keyIds :: [KeyId] }
|
||||
deriving (Ord, Eq)
|
||||
|
||||
{- If a specific gpg command was found at configure time, use it.
|
||||
- Otherwise, try to run gpg. -}
|
||||
gpgcmd :: FilePath
|
||||
gpgcmd = fromMaybe "gpg" SysConfig.gpg
|
||||
newtype GpgCmd = GpgCmd { unGpgCmd :: String }
|
||||
|
||||
{- Get gpg command to use, Just what's specified or, if a specific gpg
|
||||
- command was found at configure time, use it, or otherwise, "gpg". -}
|
||||
mkGpgCmd :: Maybe FilePath -> GpgCmd
|
||||
mkGpgCmd (Just c) = GpgCmd c
|
||||
mkGpgCmd Nothing = GpgCmd (fromMaybe "gpg" SysConfig.gpg)
|
||||
|
||||
boolGpgCmd :: GpgCmd -> [CommandParam] -> IO Bool
|
||||
boolGpgCmd (GpgCmd cmd) = boolSystem cmd
|
||||
|
||||
-- Generate an argument list to asymetrically encrypt to the given recipients.
|
||||
pkEncTo :: [String] -> [CommandParam]
|
||||
|
|
@ -76,19 +82,19 @@ stdEncryptionParams symmetric = enc symmetric ++
|
|||
]
|
||||
|
||||
{- Runs gpg with some params and returns its stdout, strictly. -}
|
||||
readStrict :: [CommandParam] -> IO String
|
||||
readStrict params = do
|
||||
readStrict :: GpgCmd -> [CommandParam] -> IO String
|
||||
readStrict (GpgCmd cmd) params = do
|
||||
params' <- stdParams params
|
||||
withHandle StdoutHandle createProcessSuccess (proc gpgcmd params') $ \h -> do
|
||||
withHandle StdoutHandle createProcessSuccess (proc cmd params') $ \h -> do
|
||||
hSetBinaryMode h True
|
||||
hGetContentsStrict h
|
||||
|
||||
{- Runs gpg, piping an input value to it, and returning its stdout,
|
||||
- strictly. -}
|
||||
pipeStrict :: [CommandParam] -> String -> IO String
|
||||
pipeStrict params input = do
|
||||
pipeStrict :: GpgCmd -> [CommandParam] -> String -> IO String
|
||||
pipeStrict (GpgCmd cmd) params input = do
|
||||
params' <- stdParams params
|
||||
withIOHandles createProcessSuccess (proc gpgcmd params') $ \(to, from) -> do
|
||||
withIOHandles createProcessSuccess (proc cmd params') $ \(to, from) -> do
|
||||
hSetBinaryMode to True
|
||||
hSetBinaryMode from True
|
||||
hPutStr to input
|
||||
|
|
@ -106,8 +112,8 @@ pipeStrict params input = do
|
|||
-
|
||||
- Note that to avoid deadlock with the cleanup stage,
|
||||
- the reader must fully consume gpg's input before returning. -}
|
||||
feedRead :: (MonadIO m, MonadMask m) => [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a
|
||||
feedRead params passphrase feeder reader = do
|
||||
feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a
|
||||
feedRead cmd params passphrase feeder reader = do
|
||||
#ifndef mingw32_HOST_OS
|
||||
-- pipe the passphrase into gpg on a fd
|
||||
(frompipe, topipe) <- liftIO System.Posix.IO.createPipe
|
||||
|
|
@ -127,13 +133,13 @@ feedRead params passphrase feeder reader = do
|
|||
go $ passphrasefile ++ params
|
||||
#endif
|
||||
where
|
||||
go params' = pipeLazy params' feeder reader
|
||||
go params' = pipeLazy cmd params' feeder reader
|
||||
|
||||
{- Like feedRead, but without passphrase. -}
|
||||
pipeLazy :: (MonadIO m, MonadMask m) => [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a
|
||||
pipeLazy params feeder reader = do
|
||||
pipeLazy :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a
|
||||
pipeLazy (GpgCmd cmd) params feeder reader = do
|
||||
params' <- liftIO $ stdParams $ Param "--batch" : params
|
||||
let p = (proc gpgcmd params')
|
||||
let p = (proc cmd params')
|
||||
{ std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = Inherit
|
||||
|
|
@ -152,8 +158,8 @@ pipeLazy params feeder reader = do
|
|||
{- Finds gpg public keys matching some string. (Could be an email address,
|
||||
- a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of
|
||||
- GnuPG's manpage.) -}
|
||||
findPubKeys :: String -> IO KeyIds
|
||||
findPubKeys for = KeyIds . parse . lines <$> readStrict params
|
||||
findPubKeys :: GpgCmd -> String -> IO KeyIds
|
||||
findPubKeys cmd for = KeyIds . parse . lines <$> readStrict cmd params
|
||||
where
|
||||
params = [Param "--with-colons", Param "--list-public-keys", Param for]
|
||||
parse = mapMaybe (keyIdField . split ":")
|
||||
|
|
@ -164,10 +170,10 @@ type UserId = String
|
|||
|
||||
{- All of the user's secret keys, with their UserIds.
|
||||
- Note that the UserId may be empty. -}
|
||||
secretKeys :: IO (M.Map KeyId UserId)
|
||||
secretKeys = catchDefaultIO M.empty makemap
|
||||
secretKeys :: GpgCmd -> IO (M.Map KeyId UserId)
|
||||
secretKeys cmd = catchDefaultIO M.empty makemap
|
||||
where
|
||||
makemap = M.fromList . parse . lines <$> readStrict params
|
||||
makemap = M.fromList . parse . lines <$> readStrict cmd params
|
||||
params = [Param "--with-colons", Param "--list-secret-keys", Param "--fixed-list-mode"]
|
||||
parse = extract [] Nothing . map (split ":")
|
||||
extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) =
|
||||
|
|
@ -193,9 +199,9 @@ maxRecommendedKeySize = 4096
|
|||
- The key is added to the secret key ring.
|
||||
- Can take a very long time, depending on system entropy levels.
|
||||
-}
|
||||
genSecretKey :: KeyType -> Passphrase -> UserId -> Size -> IO ()
|
||||
genSecretKey keytype passphrase userid keysize =
|
||||
withHandle StdinHandle createProcessSuccess (proc gpgcmd params) feeder
|
||||
genSecretKey :: GpgCmd -> KeyType -> Passphrase -> UserId -> Size -> IO ()
|
||||
genSecretKey (GpgCmd cmd) keytype passphrase userid keysize =
|
||||
withHandle StdinHandle createProcessSuccess (proc cmd params) feeder
|
||||
where
|
||||
params = ["--batch", "--gen-key"]
|
||||
feeder h = do
|
||||
|
|
@ -217,8 +223,8 @@ genSecretKey keytype passphrase userid keysize =
|
|||
{- Creates a block of high-quality random data suitable to use as a cipher.
|
||||
- It is armored, to avoid newlines, since gpg only reads ciphers up to the
|
||||
- first newline. -}
|
||||
genRandom :: Bool -> Size -> IO String
|
||||
genRandom highQuality size = checksize <$> readStrict params
|
||||
genRandom :: GpgCmd -> Bool -> Size -> IO String
|
||||
genRandom cmd highQuality size = checksize <$> readStrict cmd params
|
||||
where
|
||||
params =
|
||||
[ Param "--gen-random"
|
||||
|
|
@ -327,8 +333,8 @@ keyBlock public ls = unlines
|
|||
#ifndef mingw32_HOST_OS
|
||||
{- Runs an action using gpg in a test harness, in which gpg does
|
||||
- not use ~/.gpg/, but a directory with the test key set up to be used. -}
|
||||
testHarness :: IO a -> IO a
|
||||
testHarness a = do
|
||||
testHarness :: GpgCmd -> IO a -> IO a
|
||||
testHarness cmd a = do
|
||||
orig <- getEnv var
|
||||
bracket setup (cleanup orig) (const a)
|
||||
where
|
||||
|
|
@ -339,8 +345,8 @@ testHarness a = do
|
|||
dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
|
||||
setEnv var dir True
|
||||
-- For some reason, recent gpg needs a trustdb to be set up.
|
||||
_ <- pipeStrict [Param "--trust-model", Param "auto", Param "--update-trustdb"] []
|
||||
_ <- pipeStrict [Param "--import", Param "-q"] $ unlines
|
||||
_ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] []
|
||||
_ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines
|
||||
[testSecretKey, testKey]
|
||||
return dir
|
||||
|
||||
|
|
@ -349,22 +355,22 @@ testHarness a = do
|
|||
reset _ = unsetEnv var
|
||||
|
||||
{- Tests the test harness. -}
|
||||
testTestHarness :: IO Bool
|
||||
testTestHarness = do
|
||||
keys <- testHarness $ findPubKeys testKeyId
|
||||
testTestHarness :: GpgCmd -> IO Bool
|
||||
testTestHarness cmd = do
|
||||
keys <- testHarness cmd $ findPubKeys cmd testKeyId
|
||||
return $ KeyIds [testKeyId] == keys
|
||||
#endif
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
checkEncryptionFile :: FilePath -> Maybe KeyIds -> IO Bool
|
||||
checkEncryptionFile filename keys =
|
||||
checkGpgPackets keys =<< readStrict params
|
||||
checkEncryptionFile :: GpgCmd -> FilePath -> Maybe KeyIds -> IO Bool
|
||||
checkEncryptionFile cmd filename keys =
|
||||
checkGpgPackets cmd keys =<< readStrict cmd params
|
||||
where
|
||||
params = [Param "--list-packets", Param "--list-only", File filename]
|
||||
|
||||
checkEncryptionStream :: String -> Maybe KeyIds -> IO Bool
|
||||
checkEncryptionStream stream keys =
|
||||
checkGpgPackets keys =<< pipeStrict params stream
|
||||
checkEncryptionStream :: GpgCmd -> String -> Maybe KeyIds -> IO Bool
|
||||
checkEncryptionStream cmd stream keys =
|
||||
checkGpgPackets cmd keys =<< pipeStrict cmd params stream
|
||||
where
|
||||
params = [Param "--list-packets", Param "--list-only"]
|
||||
|
||||
|
|
@ -372,8 +378,8 @@ checkEncryptionStream stream keys =
|
|||
- symmetrically encrypted (keys is Nothing), or encrypted to some
|
||||
- public key(s).
|
||||
- /!\ The key needs to be in the keyring! -}
|
||||
checkGpgPackets :: Maybe KeyIds -> String -> IO Bool
|
||||
checkGpgPackets keys str = do
|
||||
checkGpgPackets :: GpgCmd -> Maybe KeyIds -> String -> IO Bool
|
||||
checkGpgPackets cmd keys str = do
|
||||
let (asym,sym) = partition (pubkeyEncPacket `isPrefixOf`) $
|
||||
filter (\l' -> pubkeyEncPacket `isPrefixOf` l' ||
|
||||
symkeyEncPacket `isPrefixOf` l') $
|
||||
|
|
@ -384,7 +390,7 @@ checkGpgPackets keys str = do
|
|||
(Just (KeyIds ks), ls, []) -> do
|
||||
-- Find the master key associated with the
|
||||
-- encryption subkey.
|
||||
ks' <- concat <$> mapM (keyIds <$$> findPubKeys)
|
||||
ks' <- concat <$> mapM (keyIds <$$> findPubKeys cmd)
|
||||
[ k | k:"keyid":_ <- map (reverse . words) ls ]
|
||||
return $ sort (nub ks) == sort (nub ks')
|
||||
_ -> return False
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue