xmpp: --debug now enables a sanitized dump of the XMPP protocol

So I can debug these damn google talk presence issues.

3 files changed, 28 insertions, 13 deletions

diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 66c6e7227..7d55e4b79 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -1,6 +1,6 @@
 {- git-annex XMPP client
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -33,10 +33,6 @@ import qualified Data.Map as M
 import qualified Git.Branch
 import Data.Time.Clock
 
-{- Whether to include verbose protocol dump in debug output. -}
-protocolDebug :: Bool
-protocolDebug = False
-
 xmppClientThread :: UrlRenderer -> NamedThread
 xmppClientThread urlrenderer = namedThread "XMPPClient" $
 	restartableClient . xmppClient urlrenderer =<< getAssistant id
@@ -96,8 +92,8 @@ xmppClient urlrenderer d creds =
 
 	receivenotifications selfjid = forever $ do
 		l <- decodeStanza selfjid <$> getStanza
-		when protocolDebug $
-			inAssistant $ debug ["received:", show l]
+		inAssistant $ debug
+			["received:", show $ map sanitizeXMPPEvent l]
 		mapM_ (handle selfjid) l
 
 	handle selfjid (PresenceMessage p) = do
@@ -122,8 +118,13 @@ xmppClient urlrenderer d creds =
 		(stored, sent) <- inAssistant $
 			checkImportantNetMessages (formatJID (baseJID jid), c)
 		forM_ (S.toList $ S.difference stored sent) $ \msg -> do
-			inAssistant $ debug ["sending to new client:", show c, show msg]
-			a <- inAssistant $ convertNetMsg (readdressNetMessage msg c) selfjid
+			let msg' = readdressNetMessage msg c
+			inAssistant $ debug
+				[ "sending to new client:"
+				, show c
+				, show $ sanitizeNetMessage msg'
+				]
+			a <- inAssistant $ convertNetMsg msg' selfjid
 			a
 			inAssistant $ sentImportantNetMessage msg c
 	resendImportantMessages _ _ = noop
@@ -136,6 +137,10 @@ data XMPPEvent
 	| ProtocolError ReceivedStanza
 	deriving Show
 
+sanitizeXMPPEvent :: XMPPEvent -> XMPPEvent
+sanitizeXMPPEvent (GotNetMessage m) = GotNetMessage $ sanitizeNetMessage m
+sanitizeXMPPEvent v = v
+
 {- Decodes an XMPP stanza into one or more events. -}
 decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
 decodeStanza selfjid s@(ReceivedPresence p)
@@ -173,8 +178,7 @@ decodeStanza _ s = [Unknown s]
 relayNetMessage :: JID -> Assistant (XMPP ())
 relayNetMessage selfjid = do
 	msg <- waitNetMessage
-	when protocolDebug $
-		debug ["sending:", show msg]
+	debug ["sending:", show $ sanitizeNetMessage msg]
 	handleImportant msg
 	convert msg
   where
@@ -189,8 +193,7 @@ relayNetMessage selfjid = do
 			then do
 				clients <- maybe [] (S.toList . buddyAssistants)
 					<$> getBuddy (genBuddyKey tojid) <<~ buddyList
-				when protocolDebug $
-					debug ["exploded undirected message to clients", show clients]
+				debug ["exploded undirected message to clients", show clients]
 				return $ forM_ (clients) $ \(Client jid) ->
 					putStanza $ pushMessage pushstage jid selfjid
 			else return $ putStanza $ pushMessage pushstage tojid selfjid
diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index 55bf896bd..05e51045d 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -14,6 +14,7 @@ import Data.Text (Text)
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B8
 import qualified Data.Set as S
 import qualified Data.Map as M
 
@@ -60,6 +61,16 @@ readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification s
 readdressNetMessage (Pushing _ stage) c = Pushing c stage
 readdressNetMessage m _ = m
 
+{- Convert a NetMessage to something that can be logged. -}
+sanitizeNetMessage :: NetMessage -> NetMessage
+sanitizeNetMessage (Pushing c stage) = Pushing c $ case stage of
+	ReceivePackOutput _ -> ReceivePackOutput elided
+	SendPackOutput _ -> SendPackOutput elided
+	s -> s
+  where
+  	elided = B8.pack "<elided>"
+sanitizeNetMessage m = m
+
 {- Things that initiate either side of a push, but do not actually send data. -}
 isPushInitiation :: PushStage -> Bool
 isPushInitiation CanPush = True
diff --git a/debian/changelog b/debian/changelog
index 1e68b8b9a..6d3c29e4a 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -8,6 +8,7 @@ git-annex (4.20130315) UNRELEASED; urgency=low
   * Add incrementalbackup repository group.
   * webapp: Encourage user to install git-annex on a server when adding
     a ssh server, rather than just funneling them through to rsync.
+  * xmpp: --debug now enables a sanitized dump of the XMPP protocol
 
  -- Joey Hess <joeyh@debian.org>  Fri, 15 Mar 2013 00:10:07 -0400