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.

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