unlifted connection handling

exported withConnection

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

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
+

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'
+

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

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

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