sanitize gpg output and chat messages

Just in case, only allow printable characters in this, not control
characters.

6 files changed, 49 insertions, 24 deletions

diff --git a/ControlWindow.hs b/ControlWindow.hs
index c921fbb..99fd4d3 100644
--- a/ControlWindow.hs
+++ b/ControlWindow.hs
@@ -15,6 +15,7 @@ import ControlSocket
 import VirtualTerminal
 import Gpg
 import Gpg.Wot
+import Output
 
 import System.IO
 import System.Environment
@@ -24,8 +25,7 @@ import Control.Exception
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
-import qualified Data.ByteString as B
-import Data.ByteString.UTF8 (fromString)
+import Data.ByteString.UTF8 (fromString, toString)
 import Data.Char
 import Control.Monad
 import Data.Monoid
@@ -128,7 +128,8 @@ displayInput ochan ichan promptchan responsechan = loop
 
 displayChatMessage :: ControlAction -> IO ()
 displayChatMessage (ChatMessage username msg) = do
-	B.putStr $ "<" <> val username <> "> " <> val msg <> "\n"
+	putStrLn $ sanitizeForDisplay $ toString $
+		"<" <> val username <> "> " <> val msg
 	hFlush stdout
 displayChatMessage _ = return ()
 
@@ -138,7 +139,8 @@ askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $
 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, gpgoutput) <- gpgVerify k
+	putStr $ unlines $ map sanitizeForDisplay $ lines $ toString gpgoutput
 	case v of
 		Nothing -> do
 			putStrLn "Unable to download their GnuPG key, or signature verification failed."
@@ -147,7 +149,8 @@ askToAllow ochan promptchan responsechan k@(GpgSigned pk _ _) = do
 			putStrLn "Checking the GnuPG web of trust ..."
 			ss <- isInStrongSet gpgkeyid
 			ws <- downloadWotStats gpgkeyid
-			putStrLn $ describeWot ws ss
+			putStrLn $ unlines $ map sanitizeForDisplay $
+				describeWot ws ss
 			promptconnect
   where
 	promptconnect :: IO ()
diff --git a/Gpg.hs b/Gpg.hs
index e2003d1..7d98d5c 100644
--- a/Gpg.hs
+++ b/Gpg.hs
@@ -57,7 +57,7 @@ gpgSign pk = 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
+			v <- fst <$> gpgVerifyClearSigned sig
 			case v of
 				Just (gpgkeyid, _) -> do
 					pubkey <- gpgExportPublicKey gpgkeyid
@@ -87,60 +87,68 @@ gpgExportPublicKey (GpgKeyId gpgkeyid) = do
 
 gpgImportPublicKey :: GpgKeyExport -> IO ()
 gpgImportPublicKey (GpgKeyExport (Val b)) = do
-	(Just hin, _, _, pid) <- createProcess $
+	(Just hin, Just hout, Just herr, pid) <- createProcess $
 		(proc "gpg" [ "--import"] )
 			{ std_in = CreatePipe
+			, std_out = CreatePipe
+			, std_err = CreatePipe
 			}
 	hSetBinaryMode hin True
 	B.hPut hin b
 	hClose hin
+	_ <- B.hGetContents hout
+		`concurrently` B.hGetContents herr
 	_ <- 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.
-gpgVerify :: PerhapsSigned PublicKey -> IO (Maybe GpgKeyId)
-gpgVerify (UnSigned _) = return Nothing
+gpgVerify :: PerhapsSigned PublicKey -> IO (Maybe GpgKeyId, SignInfoDesc)
+gpgVerify (UnSigned _) = return (Nothing, mempty)
 gpgVerify (GpgSigned pk gpgsig keyexport) = do
 	gpgImportPublicKey keyexport
 	go =<< gpgVerifyClearSigned gpgsig
   where
-	go Nothing = return Nothing
-	go (Just (gpgkeyid, signeddata)) = do
+	go (Nothing, s) = return (Nothing, s)
+	go (Just (gpgkeyid, signeddata), s) = 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
+			then (Just gpgkeyid, s)
+			else (Nothing, s)
+
+type SignInfoDesc = B.ByteString
 
 -- | 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.
-gpgVerifyClearSigned :: GpgSig -> IO (Maybe (GpgKeyId, B.ByteString))
+-- data, and that is returned also.
+gpgVerifyClearSigned :: GpgSig -> IO (Maybe (GpgKeyId, B.ByteString), SignInfoDesc)
 gpgVerifyClearSigned (GpgSig (Val sig)) = do
 	(statusreadh, statuswriteh) <- createPipe
 	statuswritefd <- handleToFd statuswriteh
-	(Just hin, Just hout, _, pid) <- createProcess $
+	(Just hin, Just hout, Just herr, pid) <- createProcess $
 		(proc "gpg" (verifyopts statuswritefd))
 			{ std_in = CreatePipe
 			, std_out = CreatePipe
+			, std_err = CreatePipe
 			}
 	closeFd statuswritefd
 	B.hPut hin sig
 	hClose hin
 	hSetBinaryMode hout True
-	(signeddata, mgpgkeyid) <- B.hGetContents hout
+	((signeddata, sigdesc), mgpgkeyid) <- B.hGetContents hout
+		`concurrently` B.hGetContents herr
 		`concurrently` (parseStatusFd <$> hGetContents statusreadh)
 	st <- waitForProcess pid
-	return $ if st == ExitSuccess
+	let siginfo = if st == ExitSuccess
 		then case mgpgkeyid of
 			Just gpgkeyid -> Just (gpgkeyid, signeddata)
 			Nothing -> Nothing
 		else Nothing
+	return (siginfo, sigdesc)
   where
 	verifyopts statuswritefd =
 		[ "--status-fd", show statuswritefd
diff --git a/Gpg/Wot.hs b/Gpg/Wot.hs
index f9051e9..b29ccc7 100644
--- a/Gpg/Wot.hs
+++ b/Gpg/Wot.hs
@@ -95,10 +95,10 @@ isInStrongSet :: GpgKeyId -> IO StrongSetAnalysis
 isInStrongSet k = maybe (StrongSetAnalysis False) (const $ StrongSetAnalysis True)
 	<$> downloadWotPath k knownKeyInStrongSet
 
-describeWot :: Maybe WotStats -> StrongSetAnalysis -> String
+describeWot :: Maybe WotStats -> StrongSetAnalysis -> [String]
 describeWot (Just ws) (StrongSetAnalysis ss)
-	| ss == False = theirname ++ "'s identity cannot be verified!"
-	| otherwise = unlines $
+	| ss == False = [theirname ++ "'s identity cannot be verified!"]
+	| otherwise =
 		[ theirname ++ "'s identity has been verified by as many as "
 			++ show (length sigs) ++ " people, including:"
 		, intercalate ", " $ take 10 $ nub $
@@ -110,7 +110,7 @@ describeWot (Just ws) (StrongSetAnalysis ss)
 	theirname = stripEmail (uid (key ws))
 	sigs = cross_sigs ws ++ other_sigs ws
 	bestconnectedsigs = sortOn rank sigs
-describeWot Nothing _ = unlines
+describeWot Nothing _ =
 	[ ""
 	, "Their identity cannot be verified!"
 	]
diff --git a/Output.hs b/Output.hs
new file mode 100644
index 0000000..5aa3072
--- /dev/null
+++ b/Output.hs
@@ -0,0 +1,10 @@
+module Output where
+
+import Data.Char
+
+sanitizeForDisplay :: String -> String
+sanitizeForDisplay = map go
+  where
+	go c
+		| isPrint c = c
+		| otherwise = '?'
diff --git a/Verify.hs b/Verify.hs
index b2f3805..63e81f6 100644
--- a/Verify.hs
+++ b/Verify.hs
@@ -12,9 +12,11 @@ import Crypto
 import Gpg
 import Hash
 import PrevActivity
+import Output
 
 import Control.Concurrent.STM
 import Data.Maybe
+import Data.ByteString.UTF8 (toString)
 
 verify :: VerifyOpts -> IO ()
 verify opts = go 1 startState =<< streamLog (verifyLogFile opts)
@@ -66,7 +68,8 @@ mkRecentActivity st = return (sigVerifier st, prevHashes st)
 
 addSessionKey :: Integer -> PerhapsSigned PublicKey -> State -> IO State
 addSessionKey lineno p@(GpgSigned pk _ _) st = do
-	mkid <- gpgVerify p
+	(mkid, gpgoutput) <- gpgVerify p
+	putStr $ unlines $ map sanitizeForDisplay $ lines $ toString gpgoutput
 	case mkid of
 		Nothing -> lineError lineno "Bad GnuPG signature."
 		Just _ -> do
diff --git a/debug-me.cabal b/debug-me.cabal
index 2f77b38..a7d2b15 100644
--- a/debug-me.cabal
+++ b/debug-me.cabal
@@ -94,6 +94,7 @@ Executable debug-me
     JSON
     Log
     Memory
+    Output
     Pty
     PrevActivity
     ProtocolBuffers