Browse Source

Remove diagnostic information moved to the logging system

master
Jon Kristensen 13 years ago
parent
commit
b8f3b5920d
  1. 4
      source/Network/Xmpp/Sasl.hs
  2. 27
      source/Network/Xmpp/Stream.hs
  3. 2
      source/Network/Xmpp/Tls.hs
  4. 4
      source/Network/Xmpp/Types.hs

4
source/Network/Xmpp/Sasl.hs

@ -145,10 +145,10 @@ xmppBind rsrc c = runErrorT $ do
otherwise -> do otherwise -> do
lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: " lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: "
++ show b ++ show b
throwError $ XmppOtherFailure $ "xmppBind: JID could not be unpickled from: " ++ show b throwError $ XmppOtherFailure
otherwise -> do otherwise -> do
lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received." lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received."
throwError $ XmppOtherFailure "bind: failed to bind" throwError XmppOtherFailure
where where
-- Extracts the character data in the `jid' element. -- Extracts the character data in the `jid' element.
xpJid :: PU [Node] Jid xpJid :: PU [Node] Jid

27
source/Network/Xmpp/Stream.hs

@ -80,8 +80,7 @@ streamUnpickleElem p x = do
case unpickleElem p x of case unpickleElem p x of
Left l -> do Left l -> do
liftIO $ warningM "Pontarius.Xmpp" $ "streamUnpickleElem: Unpickle error: " ++ ppUnpickleError l liftIO $ warningM "Pontarius.Xmpp" $ "streamUnpickleElem: Unpickle error: " ++ ppUnpickleError l
throwError $ XmppOtherFailure ("Unpickle error" throwError $ XmppOtherFailure
++ ppUnpickleError l)
Right r -> return r Right r -> return r
-- This is the conduit sink that handles the stream XML events. We extend it -- This is the conduit sink that handles the stream XML events. We extend it
@ -106,7 +105,7 @@ openElementFromEvents = do
Just (EventBeginElement name attrs) -> return $ Element name attrs [] Just (EventBeginElement name attrs) -> return $ Element name attrs []
_ -> do _ -> do
liftIO $ warningM "Pontarius.Xmpp" "openElementFromEvents: Stream ended." liftIO $ warningM "Pontarius.Xmpp" "openElementFromEvents: Stream ended."
throwError $ XmppOtherFailure "Stream ended" throwError XmppOtherFailure
-- Sends the initial stream:stream element and pulls the server features. If the -- Sends the initial stream:stream element and pulls the server features. If the
-- server responds in a way that is invalid, an appropriate stream error will be -- server responds in a way that is invalid, an appropriate stream error will be
@ -126,7 +125,7 @@ startStream = runErrorT $ do
case streamAddress state of case streamAddress state of
Nothing -> do Nothing -> do
lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname." lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname."
throwError $ XmppOtherFailure "server sent no hostname" throwError XmppOtherFailure
Just address -> lift $ do Just address -> lift $ do
pushXmlDecl pushXmlDecl
pushOpenElement $ pushOpenElement $
@ -183,7 +182,7 @@ startStream = runErrorT $ do
$ StreamErrorInfo sec Nothing el $ StreamErrorInfo sec Nothing el
lift $ closeStreams' lift $ closeStreams'
lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg
throwError $ XmppOtherFailure msg throwError XmppOtherFailure
checkchildren children = checkchildren children =
let to' = lookup "to" children let to' = lookup "to" children
ver' = lookup "version" children ver' = lookup "version" children
@ -271,7 +270,7 @@ streamS expectedTo = do
case e of case e of
Nothing -> do Nothing -> do
lift $ lift $ errorM "Pontarius.XMPP" "streamS: Stream ended." lift $ lift $ errorM "Pontarius.XMPP" "streamS: Stream ended."
throwError $ XmppOtherFailure "stream ended" throwError XmppOtherFailure
Just r -> streamUnpickleElem xpStreamFeatures r Just r -> streamUnpickleElem xpStreamFeatures r
-- | Connects to the XMPP server and opens the XMPP stream against the given -- | Connects to the XMPP server and opens the XMPP stream against the given
@ -361,18 +360,18 @@ pullElement = do
Left f -> return $ Left f Left f -> return $ Left f
Right Nothing -> do Right Nothing -> do
lift $ errorM "Pontarius.XMPP" "pullElement: No element." lift $ errorM "Pontarius.XMPP" "pullElement: No element."
return . Left $ XmppOtherFailure "pullElement: no element" return . Left $ XmppOtherFailure
Right (Just r) -> return $ Right r Right (Just r) -> return $ Right r
) )
[ ExL.Handler (\StreamEnd -> return $ Left StreamEndFailure) [ ExL.Handler (\StreamEnd -> return $ Left StreamEndFailure)
, ExL.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag , ExL.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag
-> do -> do
lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid XML: " ++ (show s) lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid XML: " ++ (show s)
return . Left $ XmppOtherFailure "invalid xml") return . Left $ XmppOtherFailure)
, ExL.Handler $ \(e :: InvalidEventStream) , ExL.Handler $ \(e :: InvalidEventStream)
-> do -> do
lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid event stream: " ++ (show e) lift $ errorM "Pontarius.XMPP" $ "pullElement: Invalid event stream: " ++ (show e)
return . Left $ XmppOtherFailure "invalid event stream" return . Left $ XmppOtherFailure
] ]
-- Pulls an element and unpickles it. -- Pulls an element and unpickles it.
@ -386,8 +385,7 @@ pullUnpickle p = do
case res of case res of
Left e -> do Left e -> do
lift $ errorM "Pontarius.XMPP" $ "pullUnpickle: Unpickle failed: " ++ (ppUnpickleError e) lift $ errorM "Pontarius.XMPP" $ "pullUnpickle: Unpickle failed: " ++ (ppUnpickleError e)
return . Left . XmppOtherFailure $ return . Left $ XmppOtherFailure
"pullUnpickle: unpickle failed" ++ ppUnpickleError e
Right r -> return $ Right r Right r -> return $ Right r
-- | Pulls a stanza (or stream error) from the stream. -- | Pulls a stanza (or stream error) from the stream.
@ -419,7 +417,6 @@ xmppNoStream = Stream {
errorM "Pontarius.XMPP" "xmppNoStream: No stream on receive." errorM "Pontarius.XMPP" "xmppNoStream: No stream on receive."
ExL.throwIO $ ExL.throwIO $
XmppOtherFailure XmppOtherFailure
"no Stream"
, streamFlush = return () , streamFlush = return ()
, streamClose = return () , streamClose = return ()
} }
@ -436,7 +433,7 @@ xmppNoStream = Stream {
zeroSource :: Source IO output zeroSource :: Source IO output
zeroSource = liftIO $ do zeroSource = liftIO $ do
errorM "Pontarius.XMPP" "zeroSource utilized." errorM "Pontarius.XMPP" "zeroSource utilized."
ExL.throwIO $ XmppOtherFailure "zeroSource" ExL.throwIO XmppOtherFailure
createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream)
createStream realm config = do createStream realm config = do
@ -675,13 +672,13 @@ pushIQ iqID to tp lang body stream = do
unless unless
(iqID == iqResultID r) $ liftIO $ do (iqID == iqResultID r) $ liftIO $ do
errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")."
ExL.throwIO $ XmppOtherFailure "pushIQ: id mismatch" ExL.throwIO XmppOtherFailure
-- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++
-- " /= " ++ show (iqResultID r) ++ " .") -- " /= " ++ show (iqResultID r) ++ " .")
return $ Right $ Right r return $ Right $ Right r
_ -> do _ -> do
errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type."
return . Left $ XmppOtherFailure "pushIQ: unexpected stanza type " return . Left $ XmppOtherFailure
debugConduit :: Pipe l ByteString ByteString u IO b debugConduit :: Pipe l ByteString ByteString u IO b
debugConduit = forever $ do debugConduit = forever $ do

2
source/Network/Xmpp/Tls.hs

@ -72,7 +72,7 @@ startTls params con = Ex.handle (return . Left . TlsError)
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right () Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right ()
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do
lift $ lift $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." lift $ lift $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed."
return . Left $ XmppOtherFailure "TLS initiation failed" return . Left $ XmppOtherFailure
(raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend con) (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend con)
let newHand = StreamHandle { streamSend = catchPush . psh let newHand = StreamHandle { streamSend = catchPush . psh
, streamReceive = read , streamReceive = read

4
source/Network/Xmpp/Types.hs

@ -673,7 +673,7 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
-- stream were performed when the -- stream were performed when the
-- 'StreamState' was 'Closed' -- 'StreamState' was 'Closed'
| TlsStreamSecured -- ^ Connection already secured | TlsStreamSecured -- ^ Connection already secured
| XmppOtherFailure String -- ^ Undefined condition. More | XmppOtherFailure -- ^ Undefined condition. More
-- information should be available in -- information should be available in
-- the log. -- the log.
| XmppIOException IOException -- ^ An 'IOException' | XmppIOException IOException -- ^ An 'IOException'
@ -681,7 +681,7 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception XmppFailure instance Exception XmppFailure
instance Error XmppFailure where strMsg = XmppOtherFailure instance Error XmppFailure where noMsg = XmppOtherFailure
-- ============================================================================= -- =============================================================================
-- XML TYPES -- XML TYPES

Loading…
Cancel
Save