assistant: Sanitize XMPP presence information logged for debugging.

3 files changed, 43 insertions, 16 deletions

diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 6f15505fe..417c6c976 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -84,7 +84,7 @@ xmppClient urlrenderer d creds =
 		inAssistant $ do
 			modifyDaemonStatus_ $ \s -> s
 				{ xmppClientID = Just $ xmppJID creds }
-			debug ["connected", show selfjid]
+			debug ["connected", logJid selfjid]
 
 		xmppThread $ receivenotifications selfjid
 		forever $ do
@@ -94,7 +94,7 @@ xmppClient urlrenderer d creds =
 	receivenotifications selfjid = forever $ do
 		l <- decodeStanza selfjid <$> getStanza
 		inAssistant $ debug
-			["received:", show $ map sanitizeXMPPEvent l]
+			["received:", show $ map logXMPPEvent l]
 		mapM_ (handle selfjid) l
 
 	handle selfjid (PresenceMessage p) = do
@@ -123,8 +123,8 @@ xmppClient urlrenderer d creds =
 			let msg' = readdressNetMessage msg c
 			inAssistant $ debug
 				[ "sending to new client:"
-				, show c
-				, show $ sanitizeNetMessage msg'
+				, logJid jid
+				, show $ logNetMessage msg'
 				]
 			a <- inAssistant $ convertNetMsg msg' selfjid
 			a
@@ -139,9 +139,28 @@ data XMPPEvent
 	| ProtocolError ReceivedStanza
 	deriving Show
 
-sanitizeXMPPEvent :: XMPPEvent -> XMPPEvent
-sanitizeXMPPEvent (GotNetMessage m) = GotNetMessage $ sanitizeNetMessage m
-sanitizeXMPPEvent v = v
+logXMPPEvent :: XMPPEvent -> String
+logXMPPEvent (GotNetMessage m) = logNetMessage m
+logXMPPEvent (PresenceMessage p) = logPresence p
+logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p
+logXMPPEvent v = show v
+
+logPresence :: Presence -> String
+logPresence (p@Presence { presenceFrom = Just jid }) = unwords
+	[ "Presence from"
+	, logJid jid
+	, show $ extractGitAnnexTag p
+	]
+logPresence _ = "Presence from unknown"
+
+logJid :: JID -> String
+logJid jid =
+	let name = T.unpack (buddyName jid)
+	    resource = maybe "" (T.unpack . strResource) (jidResource jid)
+	in take 1 name ++ show (length name) ++ "/" ++ resource
+
+logClient :: Client -> String
+logClient (Client jid) = logJid jid
 
 {- Decodes an XMPP stanza into one or more events. -}
 decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
@@ -180,7 +199,7 @@ decodeStanza _ s = [Unknown s]
 relayNetMessage :: JID -> Assistant (XMPP ())
 relayNetMessage selfjid = do
 	msg <- waitNetMessage
-	debug ["sending:", show $ sanitizeNetMessage msg]
+	debug ["sending:", logNetMessage msg]
 	a1 <- handleImportant msg
 	a2 <- convert msg
 	return (a1 >> a2)
@@ -197,7 +216,7 @@ relayNetMessage selfjid = do
 			then do
 				clients <- maybe [] (S.toList . buddyAssistants)
 					<$> getBuddy (genBuddyKey tojid) <<~ buddyList
-				debug ["exploded undirected message to clients", show clients]
+				debug ["exploded undirected message to clients", unwords $ map logClient 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 57ed52024..e0dcbbb56 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -10,11 +10,12 @@ module Assistant.Types.NetMessager where
 import Common.Annex
 import Assistant.Pairing
 
-import Data.Text (Text)
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as B8
+import Data.Text (Text)
+import qualified Data.Text as T
 import qualified Data.Set as S
 import qualified Data.Map as M
 
@@ -67,14 +68,20 @@ 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 n _ -> ReceivePackOutput n elided
-	SendPackOutput n _ -> SendPackOutput n elided
-	s -> s
+logNetMessage :: NetMessage -> String
+logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $
+	case stage of
+		ReceivePackOutput n _ -> ReceivePackOutput n elided
+		SendPackOutput n _ -> SendPackOutput n elided
+		s -> s
   where
   	elided = B8.pack "<elided>"
-sanitizeNetMessage m = m
+logNetMessage (PairingNotification stage c uuid) =
+	show $ PairingNotification stage (logClientID c) uuid
+logNetMessage m = show m
+
+logClientID :: ClientID -> ClientID
+logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]
 
 {- Things that initiate either side of a push, but do not actually send data. -}
 isPushInitiation :: PushStage -> Bool
diff --git a/debian/changelog b/debian/changelog
index f2531d6ee..1caab32ca 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -28,6 +28,7 @@ git-annex (4.20130418) UNRELEASED; urgency=low
   * assistant: Several improvements to performance and behavior when
     performing bulk adds of a large number of files (tens to hundreds
     of thousands).
+  * assistant: Sanitize XMPP presence information logged for debugging.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 18 Apr 2013 16:22:48 -0400