include gpg public key export in GpgSigned

This makes debug-me not rely on the gpg keyservers at all.
Before, it was only working when the user had the developer's public key
already. I thought that --verify would download from --keyserver, but
seems not.

This is a protocol breaking change! Luckily done before any release, so
ok. ProtocolBuffers renumbered.

This commit was sponsored by Denis Dzyubenko on Patreon.

1 files changed, 68 insertions, 30 deletions

diff --git a/Gpg.hs b/Gpg.hs
index 6995797..e2003d1 100644
--- a/Gpg.hs
+++ b/Gpg.hs
@@ -17,7 +17,6 @@ import System.IO
 import System.Posix.IO hiding (createPipe)
 import System.Process
 import System.Exit
-import Data.List
 import Control.Exception
 import System.Directory
 import Control.Concurrent.Async
@@ -34,6 +33,7 @@ myPublicKey (MySessionKey _ epk) (GpgSign gpgsign) = do
 		then gpgSign pk
 		else return (UnSigned pk)
 
+-- | Sign a debug-me session PublicKey with gpg.
 gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey)
 gpgSign pk = do
 	putStrLn "Using gpg to sign the debug-me session key."
@@ -53,25 +53,75 @@ gpgSign pk = do
 	st <- waitForProcess pid
 	_ <- try (removeFile tmpfile) :: IO (Either IOException ())
 	case st of
-		ExitSuccess -> return $ GpgSigned pk sig
-		ExitFailure _ -> error "gpg failed"
+		ExitSuccess -> do
+			-- Verify the just signed data to determine
+			-- the gpg public key used to sign it. The gpg 
+			-- public key is included in the GpgSigned data.
+			v <- gpgVerifyClearSigned sig
+			case v of
+				Just (gpgkeyid, _) -> do
+					pubkey <- gpgExportPublicKey gpgkeyid
+					return $ GpgSigned pk sig pubkey
+				Nothing -> error "gpg sign verification failed"
+		ExitFailure _ -> error "gpg sign failed"
+
+-- | Export gpg public key in minimal form.
+gpgExportPublicKey :: GpgKeyId -> IO GpgKeyExport
+gpgExportPublicKey (GpgKeyId gpgkeyid) = do
+	(_, Just hout, _, pid) <- createProcess $
+		(proc "gpg" opts)
+			{ std_out = CreatePipe
+			}
+	hSetBinaryMode hout True
+	b <- B.hGetContents hout
+	st <- waitForProcess pid
+	if st == ExitSuccess
+		then return $ GpgKeyExport $ Val b
+		else error "gpg --export failed"
+  where
+	opts =
+		[ "-a"
+		, "--export-options", "no-export-attributes,export-minimal"
+		, "--export", gpgkeyid
+		]
+
+gpgImportPublicKey :: GpgKeyExport -> IO ()
+gpgImportPublicKey (GpgKeyExport (Val b)) = do
+	(Just hin, _, _, pid) <- createProcess $
+		(proc "gpg" [ "--import"] )
+			{ std_in = CreatePipe
+			}
+	hSetBinaryMode hin True
+	B.hPut hin b
+	hClose hin
+	_ <- waitForProcess pid
+	return ()
 
 -- | Verify the gpg signature and return the keyid that signed it.
 -- Also makes sure that the gpg signed data is the hash of the 
 -- debug-me PublicKey.
---
--- The gpg key will be retrieved from a keyserver if necessary.
+gpgVerify :: PerhapsSigned PublicKey -> IO (Maybe GpgKeyId)
+gpgVerify (UnSigned _) = return Nothing
+gpgVerify (GpgSigned pk gpgsig keyexport) = do
+	gpgImportPublicKey keyexport
+	go =<< gpgVerifyClearSigned gpgsig
+  where
+	go Nothing = return Nothing
+	go (Just (gpgkeyid, signeddata)) = do
+		let norm = filter (not . B.null) . B8.lines
+		let pkissigned = norm signeddata == norm (val (hashValue (hash pk)))
+		return $ if pkissigned
+			then Just gpgkeyid
+			else Nothing
+
+-- | Verify a clearsigned GpgSig, returning the key id used to sign it,
+-- and the data that was signed.
 --
 -- Gpg outputs to stderr information about who signed the
 -- data, so that will be visible to the user when eg, prompting
 -- them if they want to accept a connection from that person.
---
--- This relies on gpgSign using --clearsign, so on successful
--- verification, the JSON encoded PublicKey is output to gpg's
--- stdout.
-gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO (Maybe GpgKeyId)
-gpgVerify _ (UnSigned _) = return Nothing
-gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
+gpgVerifyClearSigned :: GpgSig -> IO (Maybe (GpgKeyId, B.ByteString))
+gpgVerifyClearSigned (GpgSig (Val sig)) = do
 	(statusreadh, statuswriteh) <- createPipe
 	statuswritefd <- handleToFd statuswriteh
 	(Just hin, Just hout, _, pid) <- createProcess $
@@ -83,33 +133,21 @@ gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
 	B.hPut hin sig
 	hClose hin
 	hSetBinaryMode hout True
-	(signeddata, gpgkeyid) <- B.hGetContents hout
+	(signeddata, mgpgkeyid) <- B.hGetContents hout
 		`concurrently` (parseStatusFd <$> hGetContents statusreadh)
 	st <- waitForProcess pid
-	let norm = filter (not . B.null) . B8.lines
-	let pkissigned = norm (val (hashValue (hash pk))) == norm signeddata
-	return $ if st == ExitSuccess && pkissigned
-		then gpgkeyid
+	return $ if st == ExitSuccess
+		then case mgpgkeyid of
+			Just gpgkeyid -> Just (gpgkeyid, signeddata)
+			Nothing -> Nothing
 		else Nothing
   where
-	extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
-		then gpgopts
-		else concatMap (\s -> ["--keyserver", s]) defaultKeyServers
-			++ gpgopts
-	verifyopts statuswritefd = extraopts ++
+	verifyopts statuswritefd =
 		[ "--status-fd", show statuswritefd
 		, "--verify"
 		, "--output", "-"
 		]
 
--- | Default keyservers to use. Note that only gpg 1 needs this;
--- gpg 2 has a default keyserver.
-defaultKeyServers :: [String]
-defaultKeyServers =
-	[ "pool.sks-keyservers.net"
-	, "pgpkeys.mit.edu"
-	]
-
 parseStatusFd :: String -> Maybe GpgKeyId
 parseStatusFd = go . map words . lines
   where