diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index e1b306d..278aa4d 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -179,23 +179,28 @@ connect address hostname = do Left (StreamNotStreamElement _name) -> do _ <- pushElement $ pickleElem xpStreamError $ XmppStreamError StreamInvalidXml Nothing Nothing + xmppCloseStreams return () Left (StreamInvalidStreamNamespace _ns) -> do _ <- pushElement $ pickleElem xpStreamError $ XmppStreamError StreamInvalidNamespace Nothing Nothing + xmppCloseStreams return () Left (StreamInvalidStreamPrefix _prefix) -> do _ <- pushElement $ pickleElem xpStreamError $ XmppStreamError StreamBadNamespacePrefix Nothing Nothing + xmppCloseStreams return () -- TODO: Catch remaining xmppStartStream errors. Left (StreamWrongVersion _ver) -> do _ <- pushElement $ pickleElem xpStreamError $ XmppStreamError StreamUnsupportedVersion Nothing Nothing + xmppCloseStreams return () Left (StreamWrongLangTag _lang) -> do _ <- pushElement $ pickleElem xpStreamError $ XmppStreamError StreamInvalidXml Nothing Nothing + xmppCloseStreams return () Right () -> return () diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs index b4f2028..6203dbb 100644 --- a/source/Network/Xmpp/Monad.hs +++ b/source/Network/Xmpp/Monad.hs @@ -4,6 +4,7 @@ module Network.Xmpp.Monad where import Control.Applicative((<$>)) +import Control.Concurrent (forkIO, threadDelay) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -184,4 +185,28 @@ xmppSendIQ' iqID to tp lang body = do StreamXMLError ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ show (iqResultID iq') ++ " .") - return $ Right iq' \ No newline at end of file + return $ Right iq' + +-- | Send "" and wait for the server to finish processing and to +-- close the connection. Any remaining elements from the server and whether or +-- not we received a element from the server is returned. +xmppCloseStreams :: XmppConMonad ([Element], Bool) +xmppCloseStreams = do + send <- gets sConPushBS + cc <- gets sCloseConnection + liftIO $ send "" + void $ liftIO $ forkIO $ do + threadDelay 3000000 + (Ex.try cc) :: IO (Either Ex.SomeException ()) + return () + collectElems [] + where + -- Pulls elements from the stream until the stream ends, or an error is + -- raised. + collectElems :: [Element] -> XmppConMonad ([Element], Bool) + collectElems elems = do + result <- Ex.try pullElement + case result of + Left StreamStreamEnd -> return (elems, True) + Left _ -> return (elems, False) + Right elem -> collectElems (elem:elems) \ No newline at end of file