|
|
|
@ -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 |
|
|
|
|