diff options
| author |  Joey Hess <joey@kitenet.net> | 2013-03-16 15:29:51 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2013-03-16 15:29:51 -0400 |
| commit | d6eddd505e7df63c4fa1b96ba7bcab551691d1ff (patch) | |
| tree | a4d145aa6dba06b44ff657cf5ad3124014474d6f /Assistant/Threads/XMPPClient.hs | |
| parent | cd35bcc54529dbc926fdf92d11622e2f760f5142 (diff) | |
xmpp: --debug now enables a sanitized dump of the XMPP protocol
So I can debug these damn google talk presence issues.
Diffstat (limited to 'Assistant/Threads/XMPPClient.hs')
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 29 |
1 files changed, 16 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 |