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.

7 files changed, 131 insertions, 63 deletions

diff --git a/ControlWindow.hs b/ControlWindow.hs
index a91adc0..c921fbb 100644
--- a/ControlWindow.hs
+++ b/ControlWindow.hs
@@ -135,10 +135,10 @@ displayChatMessage _ = return ()
 askToAllow :: TMChan ControlOutput -> PromptChan -> ResponseChan -> PerhapsSigned PublicKey -> IO ()
 askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $
 	ControlOutputAction $ SessionKeyRejected pk
-askToAllow ochan promptchan responsechan k@(GpgSigned pk _) = do
+askToAllow ochan promptchan responsechan k@(GpgSigned pk _ _) = do
 	putStrLn "Someone wants to connect to this debug-me session."
 	putStrLn "Checking their GnuPG signature ..."
-	v <- gpgVerify [] k
+	v <- gpgVerify k
 	case v of
 		Nothing -> do
 			putStrLn "Unable to download their GnuPG key, or signature verification failed."
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
diff --git a/Hash.hs b/Hash.hs
index bf8e166..6fb5614 100644
--- a/Hash.hs
+++ b/Hash.hs
@@ -68,8 +68,12 @@ instance Hashable PublicKey where
 instance Hashable GpgSig where
 	hash (GpgSig v) = hash $ Tagged "GpgSig" v
 
+instance Hashable GpgKeyExport where
+	hash (GpgKeyExport v) = hash $ Tagged "GpgKeyExport" v
+
 instance Hashable a => Hashable (PerhapsSigned a) where
-	hash (GpgSigned a sig) = hash $ Tagged "GpgSigned" [hash a, hash sig]
+	hash (GpgSigned a sig export) = hash $ 
+		Tagged "GpgSigned" [hash a, hash sig, hash export]
 	hash (UnSigned a) = hash $ Tagged "UnSigned" a
 
 instance Hashable ElapsedTime where
diff --git a/ProtocolBuffers.hs b/ProtocolBuffers.hs
index 2d59528..42d3e0b 100644
--- a/ProtocolBuffers.hs
+++ b/ProtocolBuffers.hs
@@ -48,49 +48,50 @@ data MessageP a
 
 data ActivityP a = ActivityP
 	{ activityP :: Required 6 (Message a)
-	, elapsedTimeP :: Required 8 (Message ElapsedTimeP)
-	, activitySignatureP :: Required 9 (Message SignatureP)
+	, elapsedTimeP :: Required 7 (Message ElapsedTimeP)
+	, activitySignatureP :: Required 8 (Message SignatureP)
 	}
 	deriving (Generic)
 
 data ControlP = ControlP
-	{ controlP :: Required 10 (Message ControlActionP)
-	, controlSignatureP ::Required 11 (Message SignatureP)
+	{ controlP :: Required 9 (Message ControlActionP)
+	, controlSignatureP ::Required 10 (Message SignatureP)
 	}
 	deriving (Generic)
 
 data ControlActionP
 	= EnteredRejectedP
-		{ enteredRejectedP :: Required 12 (Message HashP)
-		, enteredLastAcceptedP :: Optional 13 (Message HashP)
+		{ enteredRejectedP :: Required 11 (Message HashP)
+		, enteredLastAcceptedP :: Optional 12 (Message HashP)
 		}
 	| SessionKeyP
-		{ sessionKeyP :: Required 14 (Message (PerhapsSignedP PublicKeyP)) }
+		{ sessionKeyP :: Required 13 (Message (PerhapsSignedP PublicKeyP)) }
 	| SessionKeyAcceptedP
-		{ sessionKeyAcceptedP :: Required 15 (Message PublicKeyP) }
+		{ sessionKeyAcceptedP :: Required 14 (Message PublicKeyP) }
 	| SessionKeyRejectedP
-		{ sessionKeyRejectedP :: Required 16 (Message PublicKeyP) }
+		{ sessionKeyRejectedP :: Required 15 (Message PublicKeyP) }
 	| ChatMessageP
-		{ chatMessageSenderName :: Required 17 (Value B.ByteString)
-		, chatMessage :: Required 18 (Value B.ByteString)
+		{ chatMessageSenderName :: Required 16 (Value B.ByteString)
+		, chatMessage :: Required 17 (Value B.ByteString)
 		}
 	deriving (Generic)
 
 data SignatureP
 	= Ed25519SignatureP
-		{ ed25519SignatureP :: Required 19 (Value B.ByteString) }
+		{ ed25519SignatureP :: Required 18 (Value B.ByteString) }
 	| OtherSignatureP
-		{ otherSignatureP :: Required 20 (Value B.ByteString) }
+		{ otherSignatureP :: Required 19 (Value B.ByteString) }
 	deriving (Generic)
 
 data PublicKeyP = PublicKeyP 
-	{ mkPublicKeyP :: Required 21 (Value B.ByteString) }
+	{ mkPublicKeyP :: Required 20 (Value B.ByteString) }
 	deriving (Generic)
 
 data PerhapsSignedP a
 	= GpgSignedP
-		{ gpgSignedValP :: Required 22 (Message a)
-		, gpgSigP :: Required 23 (Message GpgSigP)
+		{ gpgSignedValP :: Required 21 (Message a)
+		, gpgSigP :: Required 22 (Message GpgSigP)
+		, gpgKeyExportP :: Required 23 (Message GpgKeyExportP)
 		}
 	| UnSignedP
 		{ mkUnSignedP :: Required 24 (Message a )
@@ -101,24 +102,28 @@ data GpgSigP = GpgSigP
 	{ mkGpgSigP :: Required 25 (Value B.ByteString) }
 	deriving (Generic)
 
+data GpgKeyExportP = GpgKeyExportP
+	{ mkGpgKeyExportP :: Required 26 (Value B.ByteString) }
+	deriving (Generic)
+
 data ElapsedTimeP = ElapsedTimeP
-	{ mkElapsedTimeP :: Required 26 (Value Double) }
+	{ mkElapsedTimeP :: Required 27 (Value Double) }
 	deriving (Generic)
 
 data AnyMessageP
-	= UserP { mkUserP :: Required 27 (Message (MessageP SeenP)) }
-	| DeveloperP { mkDeveloperP :: Required 28 (Message (MessageP EnteredP)) }
+	= UserP { mkUserP :: Required 28 (Message (MessageP SeenP)) }
+	| DeveloperP { mkDeveloperP :: Required 29 (Message (MessageP EnteredP)) }
 	deriving (Generic)
 
 data HashP = HashP
-	{ hashMethodP :: Required 29 (Message HashMethodP)
-	, hashValueP :: Required 30 (Value B.ByteString)
+	{ hashMethodP :: Required 30 (Message HashMethodP)
+	, hashValueP :: Required 31 (Value B.ByteString)
 	}
 	deriving (Generic)
 
 data HashMethodP
-	= SHA512P { mkSHA512P :: Required 31 (Value Bool) }
-	| SHA3P { mkSHA3P :: Required 32 (Value Bool) }
+	= SHA512P { mkSHA512P :: Required 32 (Value Bool) }
+	| SHA3P { mkSHA3P :: Required 33 (Value Bool) }
 	deriving (Generic)
 
 -- | Conversion between protocol buffer messages and debug-me's main Types.
@@ -241,9 +246,10 @@ instance ProtocolBuffer PublicKeyP T.PublicKey where
 	fromProtocolBuffer p = T.PublicKey $ Val $ getField $ mkPublicKeyP p
 
 instance ProtocolBuffer p t => ProtocolBuffer (PerhapsSignedP p) (T.PerhapsSigned t) where
-	toProtocolBuffer (T.GpgSigned tv tg) = GpgSignedP
+	toProtocolBuffer (T.GpgSigned tv tg tk)  = GpgSignedP
 		{ gpgSignedValP = putField $ toProtocolBuffer tv
 		, gpgSigP = putField $ toProtocolBuffer tg
+		, gpgKeyExportP = putField $ toProtocolBuffer tk
 		}
 	toProtocolBuffer (T.UnSigned tv) = UnSignedP
 		{ mkUnSignedP = putField $ toProtocolBuffer tv
@@ -251,6 +257,7 @@ instance ProtocolBuffer p t => ProtocolBuffer (PerhapsSignedP p) (T.PerhapsSigne
 	fromProtocolBuffer p@(GpgSignedP {}) = T.GpgSigned
 		(fromProtocolBuffer $ getField $ gpgSignedValP p)
 		(fromProtocolBuffer $ getField $ gpgSigP p)
+		(fromProtocolBuffer $ getField $ gpgKeyExportP p)
 	fromProtocolBuffer p@(UnSignedP {}) = T.UnSigned
 		(fromProtocolBuffer $ getField $ mkUnSignedP p)
 
@@ -259,6 +266,11 @@ instance ProtocolBuffer GpgSigP T.GpgSig where
 		{ mkGpgSigP = putField ( val t) }
 	fromProtocolBuffer p = T.GpgSig $ Val $ getField $ mkGpgSigP p
 
+instance ProtocolBuffer GpgKeyExportP T.GpgKeyExport where
+	toProtocolBuffer (T.GpgKeyExport t) = GpgKeyExportP
+		{ mkGpgKeyExportP = putField ( val t) }
+	fromProtocolBuffer p = T.GpgKeyExport $ Val $ getField $ mkGpgKeyExportP p
+
 instance ProtocolBuffer ElapsedTimeP T.ElapsedTime where
 	toProtocolBuffer (T.ElapsedTime t) = ElapsedTimeP
 		{ mkElapsedTimeP = putField t }
@@ -292,6 +304,8 @@ instance Encode PublicKeyP
 instance Decode PublicKeyP
 instance Encode GpgSigP
 instance Decode GpgSigP
+instance Encode GpgKeyExportP
+instance Decode GpgKeyExportP
 instance Encode ElapsedTimeP
 instance Decode ElapsedTimeP
 instance Encode AnyMessageP
diff --git a/Role/Developer.hs b/Role/Developer.hs
index 2cc6c1c..2cdf917 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -230,7 +230,9 @@ authUser spk ichan ochan devstate logger = do
 	atomically $ writeTMChan ichan msg
 	logger $ Developer msg
 	waitresp $ case spk of
-		GpgSigned pk _ -> pk
+		-- Don't bother verifying the user's gpg public key;
+		-- normally users send UnSigned.
+		GpgSigned pk _ _ -> pk
 		UnSigned pk -> pk
   where
 	waitresp pk = do
@@ -291,7 +293,7 @@ getServerMessage ochan devstate ts = do
 	-- When other developers connect, learn their SessionKeys.
 	process (Developer msg@(ControlMessage (Control (SessionKey spk) _))) = do
 		let sigverifier = mkSigVerifier $ case spk of
-			GpgSigned pk _ -> pk
+			GpgSigned pk _ _ -> pk
 			UnSigned pk -> pk
 		if verifySigned sigverifier msg
 			then do
@@ -421,7 +423,7 @@ processSessionStart sk ochan logger dsv = do
 	sigverifier <- case sessionmsg of
 		User (ControlMessage c@(Control (SessionKey spk) _)) -> do
 			let pk = case spk of
-				GpgSigned k _ -> k
+				GpgSigned k _ _ -> k
 				UnSigned k -> k
 			let sv = mkSigVerifier pk
 			if verifySigned sv c
diff --git a/Role/User.hs b/Role/User.hs
index 49e9edf..6c6fb39 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -250,7 +250,7 @@ getDeveloperMessage' (MissingHashes wiremsg) ochan us now = do
 	case msg of
 		ControlMessage (Control (SessionKey spk) _) -> do
 			let sigverifier = mkSigVerifier $ case spk of
-				GpgSigned pk _ -> pk
+				GpgSigned pk _ _ -> pk
 				UnSigned pk -> pk
 			if verifySigned sigverifier msg
 				then return (InputMessage msg)
diff --git a/Types.hs b/Types.hs
index 8f00793..79ce289 100644
--- a/Types.hs
+++ b/Types.hs
@@ -159,12 +159,13 @@ instance DataSize PublicKey where
 
 -- | A value that may be gpg signed.
 data PerhapsSigned a
-	= GpgSigned a GpgSig
+	= GpgSigned a GpgSig GpgKeyExport
 	| UnSigned a
 	deriving (Show, Generic, Eq)
 
 instance DataSize a => DataSize (PerhapsSigned a) where
-	dataSize (GpgSigned a sig) = dataSize a + dataSize sig
+	dataSize (GpgSigned a sig export) = 
+		dataSize a + dataSize sig + dataSize export
 	dataSize (UnSigned a) = dataSize a
 
 -- | A signature made with a gpg key.
@@ -174,6 +175,13 @@ newtype GpgSig = GpgSig Val
 instance DataSize GpgSig where
 	dataSize (GpgSig s) = dataSize s
 
+-- | An export of a gpg public key.
+newtype GpgKeyExport = GpgKeyExport Val
+	deriving (Show, Generic, Eq)
+
+instance DataSize GpgKeyExport where
+	dataSize (GpgKeyExport k) = dataSize k
+
 -- | Elapsed time in seconds.
 newtype ElapsedTime = ElapsedTime Double
 	deriving (Show, Generic, Eq)
@@ -224,6 +232,8 @@ instance ToJSON PublicKey
 instance FromJSON PublicKey
 instance ToJSON GpgSig
 instance FromJSON GpgSig
+instance ToJSON GpgKeyExport
+instance FromJSON GpgKeyExport
 
 instance ToJSON (Message Seen) where
 	toJSON = genericToJSON sumOptions