From 2fa9b0decbfad98fdc846e068ce2fbb08b03f891 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Fri, 4 Jan 2013 08:00:41 +0100 Subject: [PATCH] Simplify API Drops the Connection newtype, and shows TMVar Connection instead. Hides Connection from Network.Xmpp, as the vast majority of users will not need to work with Connection directly. The related functions are now instead available from Network.Xmpp.Basic. Renames `simpleConnect' to `session', and makes it flexible in terms of authentication and whether or not to use TLS. Adds some minor documentation changes. We will need to export some session related information (such as the acquired resource, stream properties, etc.). We will also need to expose any failures encountered, probably by making `session' an ErrorT calculation. Also removed the Errors module from the Cabal file. --- pontarius-xmpp.cabal | 1 - source/Network/Xmpp.hs | 14 +--- source/Network/Xmpp/Basic.hs | 10 ++- source/Network/Xmpp/Bind.hs | 4 +- source/Network/Xmpp/Concurrent/Channels.hs | 2 +- .../Network/Xmpp/Concurrent/Channels/Types.hs | 3 +- source/Network/Xmpp/Concurrent/Threads.hs | 12 ++-- source/Network/Xmpp/Concurrent/Types.hs | 2 +- source/Network/Xmpp/Connection.hs | 41 ++++++----- source/Network/Xmpp/Sasl.hs | 4 +- source/Network/Xmpp/Sasl/Types.hs | 2 +- source/Network/Xmpp/Session.hs | 70 ++++++++----------- source/Network/Xmpp/Stream.hs | 7 +- source/Network/Xmpp/Tls.hs | 4 +- source/Network/Xmpp/Types.hs | 17 ++--- source/Network/Xmpp/Xep/InbandRegistration.hs | 6 +- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 3 +- 17 files changed, 96 insertions(+), 106 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index aa760aa..76c2f53 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -69,7 +69,6 @@ Library , Network.Xmpp.Concurrent.Threads , Network.Xmpp.Concurrent.Monad , Network.Xmpp.Connection - , Network.Xmpp.Errors , Network.Xmpp.IM.Message , Network.Xmpp.IM.Presence , Network.Xmpp.Jid diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index f7a686b..3deaaf8 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -25,19 +25,7 @@ module Network.Xmpp ( -- * Session management Session - , simpleConnect - , connectTcp - , newSession - , withConnection - , startTls - , simpleAuth - , auth - , scramSha1 - , digestMd5 - , plain - , closeConnection - , endContext - , setConnectionClosedHandler + , session -- * JID -- | A JID (historically: Jabber ID) is XMPPs native format -- for addressing entities in the network. It is somewhat similar to an e-mail diff --git a/source/Network/Xmpp/Basic.hs b/source/Network/Xmpp/Basic.hs index 5ee4058..d5129c9 100644 --- a/source/Network/Xmpp/Basic.hs +++ b/source/Network/Xmpp/Basic.hs @@ -2,16 +2,21 @@ module Network.Xmpp.Basic ( Connection(..) , ConnectionState(..) , connectTcp - , simpleConnect + , newSession + , withConnection , startTls , simpleAuth , auth , scramSha1 , digestMd5 , plain + , closeConnection , pushStanza , pullStanza - ) + , closeConnection + , endContext + , setConnectionClosedHandler + ) where @@ -21,3 +26,4 @@ import Network.Xmpp.Session import Network.Xmpp.Stream import Network.Xmpp.Tls import Network.Xmpp.Types +import Network.Xmpp.Concurrent \ No newline at end of file diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index a61e556..0e01058 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -17,6 +17,8 @@ import Network.Xmpp.Types import Control.Monad.State(modify) +import Control.Concurrent.STM.TMVar + -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element bindBody = pickleElem $ @@ -28,7 +30,7 @@ bindBody = pickleElem $ -- 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 -> Connection -> IO Jid +xmppBind :: Maybe Text -> TMVar Connection -> IO Jid xmppBind rsrc c = do answer <- pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer diff --git a/source/Network/Xmpp/Concurrent/Channels.hs b/source/Network/Xmpp/Concurrent/Channels.hs index 9516afb..c84f896 100644 --- a/source/Network/Xmpp/Concurrent/Channels.hs +++ b/source/Network/Xmpp/Concurrent/Channels.hs @@ -71,7 +71,7 @@ toChans stanzaC iqHands sta = atomically $ do -- | Creates and initializes a new Xmpp context. -newSession :: Connection -> IO Session +newSession :: TMVar Connection -> IO Session newSession con = do outC <- newTChanIO stanzaChan <- newTChanIO diff --git a/source/Network/Xmpp/Concurrent/Channels/Types.hs b/source/Network/Xmpp/Concurrent/Channels/Types.hs index 8de98f1..1648cea 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Types.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Types.hs @@ -8,7 +8,8 @@ import Data.Text (Text) import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types --- | An XMPP session context +-- | The @Session@ object holds the current state of the XMPP connection, and is +-- thus necessary for any interaction with it. data Session = Session { context :: Context , stanzaCh :: TChan Stanza -- All stanzas diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 89bf372..f1ca0b8 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -18,13 +18,15 @@ import qualified Data.ByteString as BS import Network.Xmpp.Concurrent.Types import Network.Xmpp.Connection +import Control.Concurrent.STM.TMVar + import GHC.IO (unsafeUnmask) -- Worker to read stanzas from the stream and concurrently distribute them to -- all listener threads. readWorker :: (Stanza -> IO ()) -> (StreamFailure -> IO ()) - -> TMVar Connection + -> TMVar (TMVar Connection) -> IO a readWorker onStanza onConnectionClosed stateRef = Ex.mask_ . forever $ do @@ -32,8 +34,8 @@ readWorker onStanza onConnectionClosed stateRef = -- we don't know whether pull will -- necessarily be interruptible s <- atomically $ do - con@(Connection con_) <- readTMVar stateRef - state <- sConnectionState <$> readTMVar con_ + con <- readTMVar stateRef + state <- sConnectionState <$> readTMVar con when (state == ConnectionClosed) retry return con @@ -72,11 +74,11 @@ readWorker onStanza onConnectionClosed stateRef = -- connection. startThreadsWith :: (Stanza -> IO ()) -> TVar EventHandlers - -> Connection + -> TMVar Connection -> IO (IO (), TMVar (BS.ByteString -> IO Bool), - TMVar Connection, + TMVar (TMVar Connection), ThreadId) startThreadsWith stanzaHandler eh con = do read <- withConnection' (gets $ cSend. cHand) con diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 0df18c3..0259c45 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -25,7 +25,7 @@ data Context = Context , idGenerator :: IO StanzaId -- | Lock (used by withConnection) to make sure that a maximum of one -- XmppConMonad action is executed at any given time. - , conRef :: TMVar Connection + , conRef :: TMVar (TMVar Connection) , eventHandlers :: TVar EventHandlers , stopThreads :: IO () } diff --git a/source/Network/Xmpp/Connection.hs b/source/Network/Xmpp/Connection.hs index 1d682fa..1f62a3b 100644 --- a/source/Network/Xmpp/Connection.hs +++ b/source/Network/Xmpp/Connection.hs @@ -40,45 +40,48 @@ import Text.XML.Unresolved(InvalidEventStream(..)) import System.Log.Logger import Data.ByteString.Base64 +import Control.Concurrent.STM.TMVar + + -- Enable/disable debug output -- This will dump all incoming and outgoing network taffic to the console, -- prefixed with "in: " and "out: " respectively debug :: Bool debug = False -pushElement :: Element -> StateT Connection_ IO Bool +pushElement :: Element -> StateT Connection IO Bool pushElement x = do send <- gets (cSend . cHand) liftIO . send $ renderElement x -- | Encode and send stanza -pushStanza :: Stanza -> Connection -> IO Bool +pushStanza :: Stanza -> TMVar Connection -> IO Bool pushStanza s = withConnection' . pushElement $ pickleElem xpStanza s -- XML documents and XMPP streams SHOULD be preceeded by an XML declaration. -- UTF-8 is the only supported XMPP encoding. The standalone document -- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in -- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0. -pushXmlDecl :: StateT Connection_ IO Bool +pushXmlDecl :: StateT Connection IO Bool pushXmlDecl = do con <- gets cHand liftIO $ (cSend con) "" -pushOpenElement :: Element -> StateT Connection_ IO Bool +pushOpenElement :: Element -> StateT Connection IO Bool pushOpenElement e = do sink <- gets (cSend . cHand ) liftIO . sink $ renderOpenElement e -- `Connect-and-resumes' the given sink to the connection source, and pulls a -- `b' value. -runEventsSink :: Sink Event IO b -> StateT Connection_ IO b +runEventsSink :: Sink Event IO b -> StateT Connection IO b runEventsSink snk = do source <- gets cEventSource (src', r) <- lift $ source $$++ snk modify (\s -> s{cEventSource = src'}) return r -pullElement :: StateT Connection_ IO Element +pullElement :: StateT Connection IO Element pullElement = do Ex.catches (do e <- runEventsSink (elements =$ await) @@ -94,7 +97,7 @@ pullElement = do ] -- Pulls an element and unpickles it. -pullUnpickle :: PU [Node] a -> StateT Connection_ IO a +pullUnpickle :: PU [Node] a -> StateT Connection IO a pullUnpickle p = do res <- unpickleElem p <$> pullElement case res of @@ -103,7 +106,7 @@ pullUnpickle p = do -- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream -- error. -pullStanza :: Connection -> IO Stanza +pullStanza :: TMVar Connection -> IO Stanza pullStanza = withConnection' $ do res <- pullUnpickle xpStreamStanza case res of @@ -121,9 +124,9 @@ catchPush p = Ex.catch _ -> Ex.throwIO e ) --- -- Connection_ state used when there is no connection. -xmppNoConnection :: Connection_ -xmppNoConnection = Connection_ +-- -- Connection state used when there is no connection. +xmppNoConnection :: Connection +xmppNoConnection = Connection { cHand = Hand { cSend = \_ -> return False , cRecv = \_ -> Ex.throwIO $ StreamOtherFailure @@ -147,8 +150,8 @@ xmppNoConnection = Connection_ zeroSource = liftIO . Ex.throwIO $ StreamOtherFailure -- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and --- updates the XmppConMonad Connection_ state. -connectTcpRaw :: HostName -> PortID -> Text -> IO Connection +-- updates the XmppConMonad Connection state. +connectTcpRaw :: HostName -> PortID -> Text -> IO (TMVar Connection) connectTcpRaw host port hostname = do let PortNumber portNumber = port debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ @@ -172,7 +175,7 @@ connectTcpRaw host port hostname = do , cFlush = hFlush h , cClose = hClose h } - let con = Connection_ + let con = Connection { cHand = hand , cEventSource = eSource , sFeatures = (SF Nothing [] []) @@ -196,8 +199,8 @@ connectTcpRaw host port hostname = do return d --- Closes the connection and updates the XmppConMonad Connection_ state. -killConnection :: Connection -> IO (Either Ex.SomeException ()) +-- Closes the connection and updates the XmppConMonad Connection state. +killConnection :: TMVar Connection -> IO (Either Ex.SomeException ()) killConnection = withConnection $ do cc <- gets (cClose . cHand) err <- liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) @@ -211,7 +214,7 @@ pushIQ' :: StanzaId -> IQRequestType -> Maybe LangTag -> Element - -> Connection + -> TMVar Connection -> IO (Either IQError IQResult) pushIQ' iqID to tp lang body con = do pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) con @@ -231,7 +234,7 @@ pushIQ' iqID to tp lang body con = do -- | 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. -closeStreams :: Connection -> IO ([Element], Bool) +closeStreams :: TMVar Connection -> IO ([Element], Bool) closeStreams = withConnection $ do send <- gets (cSend . cHand) cc <- gets (cClose . cHand) @@ -244,7 +247,7 @@ closeStreams = withConnection $ do where -- Pulls elements from the stream until the stream ends, or an error is -- raised. - collectElems :: [Element] -> StateT Connection_ IO ([Element], Bool) + collectElems :: [Element] -> StateT Connection IO ([Element], Bool) collectElems es = do result <- Ex.try pullElement case result of diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index 0563398..9b3df03 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -38,12 +38,14 @@ import qualified System.Random as Random import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Mechanisms +import Control.Concurrent.STM.TMVar + -- | Uses the first supported mechanism to authenticate, if any. Updates the -- state with non-password credentials and restarts the stream upon -- success. xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their -- corresponding handlers - -> Connection + -> TMVar Connection -> IO (Either AuthError ()) xmppSasl handlers = withConnection $ do -- Chooses the first mechanism that is acceptable by both the client and the diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index 8c104d3..5f09f51 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -29,7 +29,7 @@ data SaslElement = SaslSuccess (Maybe Text.Text) -- | SASL mechanism XmppConnection computation, with the possibility of throwing -- an authentication error. -type SaslM a = ErrorT AuthError (StateT Connection_ IO) a +type SaslM a = ErrorT AuthError (StateT Connection IO) a type Pairs = [(ByteString, ByteString)] diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index 0902407..304feef 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -21,47 +21,35 @@ import Network.Xmpp.Sasl.Types import Network.Xmpp.Stream import Network.Xmpp.Tls import Network.Xmpp.Types +import Control.Concurrent.STM.TMVar +import Data.Maybe --- | The quick and easy way to set up a connection to an XMPP server --- --- This will --- --- * connect to the host --- --- * secure the connection with TLS --- --- * authenticate to the server using either SCRAM-SHA1 (preferred) or --- Digest-MD5 --- --- * bind a resource --- --- * return the full JID you have been assigned --- --- Note that the server might assign a different resource even when we send --- a preference. -simpleConnect :: HostName -- ^ Host to connect to - -> PortID -- ^ Port to connec to - -> Text -- ^ Hostname of the server (to distinguish the XMPP - -- service) - -> Text -- ^ User name (authcid) - -> Text -- ^ Password - -> Maybe Text -- ^ Desired resource (or Nothing to let the server - -- decide) - -> IO Session -simpleConnect host port hostname username password resource = do - con' <- connectTcp host port hostname - con <- case con' of - Left e -> Ex.throwIO e - Right r -> return r - startTls exampleParams con - saslResponse <- simpleAuth username password resource con - case saslResponse of - Right jid -> newSession con - Left e -> error $ show e - +-- | Creates a 'Session' object by setting up a connection with an XMPP server. +-- +-- Will connect to the specified host, optionally secure the connection with +-- TLS, as well as optionally authenticate and acquire an XMPP resource. +session :: HostName -- ^ Host to connect to + -> Text -- ^ The realm host name (to + -- distinguish the XMPP service) + -> PortID -- ^ Port to connect to + -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the + -- connection to the server is + -- desired + -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired + -- JID resource (or Nothing to let + -- the server decide) + -> IO Session -- TODO: ErrorT +session hostname realm port tls sasl = do + con' <- connectTcp hostname port realm + con <- case con' of + Left e -> Ex.throwIO e + Right c -> return c + if isJust tls then startTls (fromJust tls) con >> return () else return () -- TODO: Eats TlsFailure + saslResponse <- if isJust sasl then auth (fst $ fromJust sasl) (snd $ fromJust sasl) con >> return () else return () -- TODO: Eats AuthError + newSession con -- | Connect to host with given address. -connectTcp :: HostName -> PortID -> Text -> IO (Either StreamFailure Connection) +connectTcp :: HostName -> PortID -> Text -> IO (Either StreamFailure (TMVar Connection)) connectTcp address port hostname = do con <- connectTcpRaw address port hostname result <- withConnection startStream con @@ -104,7 +92,7 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" -- Sends the session IQ set element and waits for an answer. Throws an error if -- if an IQ error stanza is returned from the server. -startSession :: Connection -> IO () +startSession :: TMVar Connection -> IO () startSession con = do answer <- pushIQ' "session" Nothing Set Nothing sessionXml con case answer of @@ -115,7 +103,7 @@ startSession con = do -- resource. auth :: [SaslHandler] -> Maybe Text - -> Connection + -> TMVar Connection -> IO (Either AuthError Jid) auth mechanisms resource con = runErrorT $ do ErrorT $ xmppSasl mechanisms con @@ -131,7 +119,7 @@ simpleAuth :: Text.Text -- ^ The username -> Text.Text -- ^ The password -> Maybe Text -- ^ The desired resource or 'Nothing' to let the -- server assign one - -> Connection + -> TMVar Connection -> IO (Either AuthError Jid) simpleAuth username passwd resource = flip auth resource $ [ -- TODO: scramSha1Plus diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index a06b3e3..bf9ad69 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -21,7 +21,6 @@ import Data.XML.Pickle import Data.XML.Types import Network.Xmpp.Connection -import Network.Xmpp.Errors import Network.Xmpp.Pickle import Network.Xmpp.Types import Network.Xmpp.Marshal @@ -66,7 +65,7 @@ openElementFromEvents = do -- server responds in a way that is invalid, an appropriate stream error will be -- generated, the connection to the server will be closed, and a StreamFilure -- will be produced. -startStream :: StateT Connection_ IO (Either StreamFailure ()) +startStream :: StateT Connection IO (Either StreamFailure ()) startStream = runErrorT $ do state <- lift $ get con <- liftIO $ mkConnection state @@ -117,7 +116,7 @@ startStream = runErrorT $ do closeStreamWithError con StreamBadNamespacePrefix Nothing | otherwise -> ErrorT $ checkchildren con (flattenAttrs attrs) where - -- closeStreamWithError :: MonadIO m => Connection -> StreamErrorCondition -> + -- closeStreamWithError :: MonadIO m => TMVar Connection -> StreamErrorCondition -> -- Maybe Element -> ErrorT StreamFailure m () closeStreamWithError con sec el = do liftIO $ do @@ -157,7 +156,7 @@ flattenAttrs attrs = Prelude.map (\(name, content) -> -- Sets a new Event source using the raw source (of bytes) -- and calls xmppStartStream. -restartStream :: StateT Connection_ IO (Either StreamFailure ()) +restartStream :: StateT Connection IO (Either StreamFailure ()) restartStream = do raw <- gets (cRecv . cHand) let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index f3db8d5..5464341 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -22,6 +22,8 @@ import Network.Xmpp.Pickle(ppElement) import Network.Xmpp.Stream import Network.Xmpp.Types +import Control.Concurrent.STM.TMVar + mkBackend con = Backend { backendSend = \bs -> void (cSend con bs) , backendRecv = cRecv con , backendFlush = cFlush con @@ -74,7 +76,7 @@ exampleParams = TLS.defaultParamsClient -- Pushes ", waits for "", performs the TLS handshake, and -- restarts the stream. -startTls :: TLS.TLSParams -> Connection -> IO (Either TlsFailure ()) +startTls :: TLS.TLSParams -> TMVar Connection -> IO (Either TlsFailure ()) startTls params con = Ex.handle (return . Left . TlsError) . flip withConnection con . runErrorT $ do diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 9d33266..58d66c2 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -33,7 +33,6 @@ module Network.Xmpp.Types , Version(..) , HandleLike(..) , Connection(..) - , Connection_(..) , withConnection , withConnection' , mkConnection @@ -755,7 +754,7 @@ data HandleLike = Hand { cSend :: BS.ByteString -> IO Bool , cClose :: IO () } -data Connection_ = Connection_ +data Connection = Connection { sConnectionState :: !ConnectionState -- ^ State of -- connection , cHand :: HandleLike @@ -789,10 +788,8 @@ data Connection_ = Connection_ } -newtype Connection = Connection {unConnection :: TMVar Connection_} - -withConnection :: StateT Connection_ IO c -> Connection -> IO c -withConnection action (Connection con) = bracketOnError +withConnection :: StateT Connection IO c -> TMVar Connection -> IO c +withConnection action con = bracketOnError (atomically $ takeTMVar con) (atomically . putTMVar con ) (\c -> do @@ -802,15 +799,15 @@ withConnection action (Connection con) = bracketOnError ) -- nonblocking version. Changes to the connection are ignored! -withConnection' :: StateT Connection_ IO b -> Connection -> IO b -withConnection' action (Connection con) = do +withConnection' :: StateT Connection IO b -> TMVar Connection -> IO b +withConnection' action con = do con_ <- atomically $ readTMVar con (r, _) <- runStateT action con_ return r -mkConnection :: Connection_ -> IO Connection -mkConnection con = Connection `fmap` (atomically $ newTMVar con) +mkConnection :: Connection -> IO (TMVar Connection) +mkConnection con = {- Connection `fmap` -} (atomically $ newTMVar con) -- | Failure conditions that may arise during TLS negotiation. diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index 7f433ef..6e14447 100644 --- a/source/Network/Xmpp/Xep/InbandRegistration.hs +++ b/source/Network/Xmpp/Xep/InbandRegistration.hs @@ -71,7 +71,7 @@ emptyQuery = Query Nothing False False [] -- if r then return True else g -query :: IQRequestType -> Query -> Connection -> IO (Either IbrError Query) +query :: IQRequestType -> Query -> TMVar Connection -> IO (Either IbrError Query) query queryType x con = do answer <- pushIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con case answer of @@ -97,7 +97,7 @@ mapError f = mapErrorT (liftM $ left f) -- | Retrieve the necessary fields and fill them in to register an account with -- the server registerWith :: [(Field, Text.Text)] - -> Connection + -> TMVar Connection -> IO (Either RegisterError Query) registerWith givenFields con = runErrorT $ do fs <- mapError IbrError . ErrorT $ requestFields con @@ -114,7 +114,7 @@ registerWith givenFields con = runErrorT $ do -- | Terminate your account on the server. You have to be logged in for this to -- work. You connection will most likely be terminated after unregistering. -unregister :: Connection -> IO (Either IbrError Query) +unregister :: TMVar Connection -> IO (Either IbrError Query) unregister = query Set $ emptyQuery {remove = True} requestFields con = runErrorT $ do diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index 5eaf192..2138017 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -31,6 +31,7 @@ import Network.Xmpp.Concurrent.Types import Network.Xmpp.Connection import Network.Xmpp.Pickle import Network.Xmpp.Types +import Control.Concurrent.STM.TMVar data DiscoError = DiscoNoQueryElement | DiscoIQError IQError @@ -105,7 +106,7 @@ queryInfo to node context = do xmppQueryInfo :: Maybe Jid -> Maybe Text.Text - -> Connection + -> TMVar Connection -> IO (Either DiscoError QueryInfoResult) xmppQueryInfo to node con = do res <- pushIQ' "info" to Get Nothing queryBody con