From fc63b62babd800789ea50aef11d2c42d3963839b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 29 Apr 2012 18:25:16 +0200 Subject: [PATCH] unlifted connection handling exported withConnection --- src/Network/XMPP.hs | 25 ++++++++----------------- src/Network/XMPP/Bind.hs | 9 ++++----- src/Network/XMPP/Monad.hs | 13 +++++++++++++ src/Network/XMPP/Session.hs | 13 +++++++------ src/Network/XMPP/TLS.hs | 5 ++--- src/Tests.hs | 15 ++++++++------- 6 files changed, 42 insertions(+), 38 deletions(-) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 84bf2be..ecc7e5e 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -37,6 +37,7 @@ module Network.XMPP withNewSession , withSession , newSession + , withConnection , connect , startTLS , auth @@ -161,14 +162,8 @@ import Network.XMPP.Types import Control.Monad.Error -- | Connect to host with given address. -xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) -xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream - --- | Attempts to secure the connection using TLS. Will return --- 'TLSNoServerSupport' when the server does not offer TLS or does not --- expect it at this time. -startTLS :: TLS.TLSParams -> XMPP (Either XMPPTLSError ()) -startTLS = withConnection . xmppStartTLS +connect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) +connect address hostname = xmppRawConnect address hostname >> xmppStartStream -- | Authenticate to the server with the given username and password -- and bind a resource @@ -176,13 +171,9 @@ auth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -- assign one - -> XMPP (Either AuthError Text.Text) + -> XMPPConMonad (Either AuthError Text.Text) auth username passwd resource = runErrorT $ do - ErrorT . withConnection $ xmppSASL username passwd - res <- lift $ xmppBind resource - lift $ startSession - return res - --- | Connect to an xmpp server -connect :: HostName -> Text -> XMPP (Either StreamError ()) -connect address hostname = withConnection $ xmppConnect address hostname + ErrorT $ xmppSASL username passwd + res <- lift $ xmppBind resource + lift $ xmppStartSession + return res diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 77b25c3..b371883 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -11,7 +11,7 @@ import Data.XML.Types import Network.XMPP.Types import Network.XMPP.Pickle -import Network.XMPP.Concurrent +import Network.XMPP.Monad -- A `bind' element. @@ -29,7 +29,6 @@ bindBody rsrc = (pickleElem rsrc ) - -- Extracts the character data in the `jid' element. jidP :: PU [Node] JID @@ -39,10 +38,10 @@ jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) -- Sends a (synchronous) IQ set request for a (`Just') given or -- server-generated resource and extract the JID from the non-error -- response. - -xmppBind :: Maybe Text -> XMPP Text +xmppBind :: Maybe Text -> XMPPConMonad Text xmppBind rsrc = do - answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) + answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling let Right (JID _n _d (Just r)) = unpickleElem jidP b return r + diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 34bc566..d3a1108 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -137,3 +137,16 @@ xmppKillConnection = do cc <- gets sCloseConnection liftIO cc put xmppZeroConState + +xmppSendIQ' iqID to tp lang body = do + push . IQRequestS $ IQRequest iqID Nothing to lang tp body + res <- pullPickle $ xpEither xpIQError xpIQResult + case res of + Left e -> return $ Left e + Right iq' -> do + unless (iqID == iqResultID iq') . liftIO . Ex.throwIO $ + StreamXMLError + ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ + " /= " ++ show (iqResultID iq') ++ " .") + return $ Right iq' + diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index b21c265..e164987 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -25,12 +25,13 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" , iqRequestPayload = sessionXML } -xmppSession :: XMPPConMonad () -xmppSession = do - push $ sessionIQ - answer <- pullStanza - let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer - return () +xmppStartSession :: XMPPConMonad () +xmppStartSession = do + answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML + case answer of + Left e -> error $ show e + Right _ -> return () + startSession :: XMPP () startSession = do diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 5d2418d..c80a8a5 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -45,9 +45,8 @@ data XMPPTLSError = TLSError TLSError instance Error XMPPTLSError where noMsg = TLSNoConnection -- TODO: What should we choose here? - -xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) -xmppStartTLS params = Ex.handle (return . Left . TLSError) +startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) +startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do features <- lift $ gets sFeatures handle' <- lift $ gets sConHandle diff --git a/src/Tests.hs b/src/Tests.hs index ee381c4..d0b8c25 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -95,13 +95,14 @@ runMain debug number = do withNewSession $ do setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) debug' "running" - connect "localhost" "species64739.dyndns.org" - startTLS exampleParams - saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) - case saslResponse of - Right _ -> return () - Left e -> error $ show e - debug' "session standing" + withConnection $ do + connect "localhost" "species64739.dyndns.org" + startTLS exampleParams + saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) + case saslResponse of + Right _ -> return () + Left e -> error $ show e + debug' "session standing" sendPresence presenceOnline fork autoAccept sendPresence $ presenceSubscribe them