From 89d4e18cdb6ed1c3e7916dd66cf907bedf58a549 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 30 Apr 2017 13:09:26 -0400
Subject: dump developer state on protocol error

---
 Crypto.hs          | 18 ++++++++++++------
 Role/Developer.hs  | 11 ++++++-----
 Role/Downloader.hs |  2 +-
 3 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/Crypto.hs b/Crypto.hs
index 03228e8..3c4bf21 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -48,7 +48,7 @@ toSign = val . hashValue . hashExceptSignature
 
 -- | Verifiy the signature of a Signed value.
 verifySigned :: Signed v => SigVerifier -> v -> Bool
-verifySigned (SigVerifier verifier) v =
+verifySigned (SigVerifier _ verifier) v =
 	case getSignature v of
 		Ed25519Signature (Val s) -> 
 			case Ed25519.signature s of
@@ -56,21 +56,27 @@ verifySigned (SigVerifier verifier) v =
 				CryptoFailed _ -> False
 		OtherSignature _ -> False
 
-data SigVerifier = SigVerifier (B.ByteString -> Ed25519.Signature -> Bool)
+data SigVerifier = SigVerifier Int (B.ByteString -> Ed25519.Signature -> Bool)
+
+instance Show SigVerifier where
+	show (SigVerifier n _) = "SigVerifier (" ++ show n ++ ")"
 
 mkSigVerifier :: PublicKey -> SigVerifier
 mkSigVerifier (PublicKey (Val pk)) = 
 	case Ed25519.publicKey pk of
-		CryptoPassed pk' -> SigVerifier (Ed25519.verify pk')
+		CryptoPassed pk' -> SigVerifier 1 (Ed25519.verify pk')
 		CryptoFailed _ -> mempty
 
 instance Monoid SigVerifier where
-	mempty = SigVerifier $ \_b _s -> False
-	mappend (SigVerifier a) (SigVerifier b) =
-		SigVerifier $ \d s -> b d s || a d s
+	mempty = SigVerifier 0 $ \_b _s -> False
+	mappend (SigVerifier na a) (SigVerifier nb b) =
+		SigVerifier (na+nb) $ \d s -> b d s || a d s
 
 data MySessionKey = MySessionKey Ed25519.SecretKey Ed25519.PublicKey
 
+instance Show MySessionKey where
+	show _ = "<MySessionKey>"
+
 genMySessionKey :: IO MySessionKey
 genMySessionKey = do
 	-- Crypto.Random.Entropy may use rdrand, or /dev/random.
diff --git a/Role/Developer.hs b/Role/Developer.hs
index 1deb3a0..56af3b4 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -115,6 +115,7 @@ data DeveloperState = DeveloperState
 	, developerSigVerifier :: SigVerifier
 	-- ^ Used to verify signatures on messages from other developers.
 	}
+	deriving (Show)
 
 -- | RecentActivity that uses the DeveloperState.
 developerStateRecentActivity :: TMVar (TVar DeveloperState) -> RecentActivity
@@ -242,13 +243,13 @@ authUser spk ichan ochan devstate logger = do
 data Output
 	= TtyOutput B.ByteString 
 	| Beep
-	| ProtocolError String
+	| ProtocolError DeveloperState String
 	| GotControl ControlAction
 	| NoOutput
 
 emitOutput :: Output -> IO ()
-emitOutput (ProtocolError e) =
-	error ("Protocol error: " ++ e)
+emitOutput (ProtocolError ds e) =
+	error ("Protocol error: " ++ e ++ "\nState: " ++ show ds)
 emitOutput (TtyOutput b) = do
 	B.hPut stdout b
 	hFlush stdout
@@ -275,7 +276,7 @@ getServerMessage ochan devstate ts = do
 				then do
 					o <- processuser ds msg
 					return (Just (o, User msg))
-				else return $ Just (ProtocolError $ "Bad signature on message from user: " ++ show msg, User msg)
+				else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg)
 		-- When other developers connect, learn their SessionKeys.
 		Just (Developer msg@(ControlMessage (Control (SessionKey spk) _))) -> do
 			let sigverifier = mkSigVerifier $ case spk of
@@ -306,7 +307,7 @@ getServerMessage ochan devstate ts = do
 			then do
 				writeTVar devstate ds'
 				return (TtyOutput b)
-			else return (ProtocolError $ "Illegal Seen value: " ++ show act)
+			else return (ProtocolError ds $ "Illegal Seen value: " ++ show act)
 	processuser ds (ControlMessage (Control (Rejected _) _)) = do
 		-- When they rejected a message we sent,
 		-- anything we sent subsequently will
diff --git a/Role/Downloader.hs b/Role/Downloader.hs
index c3d6b73..094e7de 100644
--- a/Role/Downloader.hs
+++ b/Role/Downloader.hs
@@ -32,5 +32,5 @@ downloader dsv _ichan ochan sid = do
 			Just (o, msg) -> do
 				_ <- logger msg
 				case o of
-					ProtocolError e -> error ("Protocol error: " ++ e)
+					ProtocolError {} -> emitOutput o
 					_ -> go logger st
-- 
cgit v1.2.3