assistant: Sanitize XMPP presence information logged for debugging.
This commit is contained in:
Joey Hess
parent
affb89a699
commit
46529c0129
3 changed files with 43 additions and 16 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
1
debian/changelog
vendored
1
debian/changelog
vendored
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue