diff options
Diffstat (limited to 'Utility/Gpg.hs')
| -rw-r--r-- | Utility/Gpg.hs | 90 |
1 files changed, 48 insertions, 42 deletions
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 3e3a58013..1ac03ef54 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -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 |