From e318696981749b13bc7d28de971e342b17bd948d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 13 Mar 2013 17:29:22 +0100 Subject: [PATCH] wrap the stream object (TMVar Stream) in a newtype rename StreamState to ConnectionState rename Stream to StreamState add Stream newtype --- source/Network/Xmpp/Concurrent.hs | 2 +- source/Network/Xmpp/Concurrent/Threads.hs | 12 ++-- source/Network/Xmpp/Concurrent/Types.hs | 2 +- source/Network/Xmpp/Sasl.hs | 10 +-- source/Network/Xmpp/Sasl/Common.hs | 20 +++--- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 4 +- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs | 2 +- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 4 +- source/Network/Xmpp/Sasl/Types.hs | 2 +- source/Network/Xmpp/Stream.hs | 65 ++++++++++--------- source/Network/Xmpp/Tls.hs | 6 +- source/Network/Xmpp/Types.hs | 9 ++- source/Network/Xmpp/Xep/InbandRegistration.hs | 6 +- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 2 +- 14 files changed, 75 insertions(+), 71 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 28ecf70..b2f32da 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -90,7 +90,7 @@ toChans stanzaC outC iqHands sta = atomically $ do iqID (Right iq') = iqResultID iq' -- | Creates and initializes a new Xmpp context. -newSession :: TMVar Stream -> SessionConfiguration -> IO (Either XmppFailure Session) +newSession :: Stream -> SessionConfiguration -> IO (Either XmppFailure Session) newSession stream config = runErrorT $ do outC <- lift newTChanIO stanzaChan <- lift newTChanIO diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 56eb3e0..f1ce15d 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -29,7 +29,7 @@ import System.Log.Logger -- all listener threads. readWorker :: (Stanza -> IO ()) -> (XmppFailure -> IO ()) - -> TMVar (TMVar Stream) + -> TMVar Stream -> IO a readWorker onStanza onConnectionClosed stateRef = Ex.mask_ . forever $ do @@ -37,11 +37,11 @@ readWorker onStanza onConnectionClosed stateRef = -- we don't know whether pull will -- necessarily be interruptible s <- atomically $ do - con <- readTMVar stateRef - state <- streamState <$> readTMVar con + s@(Stream con) <- readTMVar stateRef + state <- streamConnectionState <$> readTMVar con when (state == Closed) retry - return con + return s allowInterrupt Just <$> pullStanza s ) @@ -79,10 +79,10 @@ readWorker onStanza onConnectionClosed stateRef = -- connection. startThreadsWith :: (Stanza -> IO ()) -> TVar EventHandlers - -> TMVar Stream + -> Stream -> IO (Either XmppFailure (IO (), TMVar (BS.ByteString -> IO Bool), - TMVar (TMVar Stream), + TMVar Stream, ThreadId)) startThreadsWith stanzaHandler eh con = do read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 2ac37c8..008d853 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -44,7 +44,7 @@ data Session = Session , idGenerator :: IO StanzaID -- | Lock (used by withStream) to make sure that a maximum of one -- Stream action is executed at any given time. - , streamRef :: TMVar (TMVar Stream) + , streamRef :: TMVar (Stream) , eventHandlers :: TVar EventHandlers , stopThreads :: IO () , conf :: SessionConfiguration diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index d4119dd..cab4c6d 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -66,7 +66,7 @@ import Control.Monad.Error -- authentication fails, or an `XmppFailure' if anything else fails. xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their -- corresponding handlers - -> TMVar Stream + -> Stream -> IO (Either XmppFailure (Maybe AuthFailure)) xmppSasl handlers stream = do debugM "Pontarius.Xmpp" "xmppSasl: Attempts to authenticate..." @@ -77,7 +77,7 @@ xmppSasl handlers stream = do case (filter (\(name, _) -> name `elem` mechanisms)) handlers of [] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms (_name, handler):_ -> do - cs <- gets streamState + cs <- gets streamConnectionState case cs of Closed -> do lift $ errorM "Pontarius.Xmpp" "xmppSasl: Stream state closed." @@ -102,7 +102,7 @@ xmppSasl handlers stream = do -- resource. auth :: [SaslHandler] -> Maybe Text - -> TMVar Stream + -> Stream -> IO (Either XmppFailure (Maybe AuthFailure)) auth mechanisms resource con = runErrorT $ do ErrorT $ xmppSasl mechanisms con @@ -127,7 +127,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 -> TMVar Stream -> IO (Either XmppFailure Jid) +xmppBind :: Maybe Text -> Stream -> IO (Either XmppFailure Jid) xmppBind rsrc c = runErrorT $ do lift $ debugM "Pontarius.Xmpp" "Attempts to bind..." answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c @@ -175,7 +175,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 :: TMVar Stream -> IO Bool +startSession :: Stream -> IO Bool startSession con = do debugM "Pontarius.XMPP" "startSession: Pushing `session' IQ set stanza..." answer <- pushIQ "session" Nothing Set Nothing sessionXml con diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 6a34aec..3a5382c 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -31,7 +31,7 @@ import qualified System.Random as Random import Control.Monad.State.Strict ---makeNonce :: ErrorT AuthFailure (StateT Stream IO) BS.ByteString +--makeNonce :: ErrorT AuthFailure (StateT StreamState IO) BS.ByteString makeNonce :: IO BS.ByteString makeNonce = do g <- liftIO Random.newStdGen @@ -108,7 +108,7 @@ xpSaslElement = xpAlt saslSel quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Bool +saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool saslInit mechanism payload = do r <- lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . B64.encode <$> payload @@ -117,7 +117,7 @@ saslInit mechanism payload = do Right b -> return b -- | Pull the next element. -pullSaslElement :: ErrorT AuthFailure (StateT Stream IO) SaslElement +pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement = do r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) case r of @@ -126,7 +126,7 @@ pullSaslElement = do Right (Right r) -> return r -- | Pull the next element, checking that it is a challenge. -pullChallenge :: ErrorT AuthFailure (StateT Stream IO) (Maybe BS.ByteString) +pullChallenge :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) pullChallenge = do e <- pullSaslElement case e of @@ -137,12 +137,12 @@ pullChallenge = do _ -> throwError AuthOtherFailure -- TODO: Log -- | Extract value from Just, failing with AuthOtherFailure on Nothing. -saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT Stream IO) a +saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT StreamState IO) a saslFromJust Nothing = throwError $ AuthOtherFailure -- TODO: Log saslFromJust (Just d) = return d -- | Pull the next element and check that it is success. -pullSuccess :: ErrorT AuthFailure (StateT Stream IO) (Maybe Text.Text) +pullSuccess :: ErrorT AuthFailure (StateT StreamState IO) (Maybe Text.Text) pullSuccess = do e <- pullSaslElement case e of @@ -151,7 +151,7 @@ pullSuccess = do -- | Pull the next element. When it's success, return it's payload. -- If it's a challenge, send an empty response and pull success. -pullFinalMessage :: ErrorT AuthFailure (StateT Stream IO) (Maybe BS.ByteString) +pullFinalMessage :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString) pullFinalMessage = do challenge2 <- pullSaslElement case challenge2 of @@ -167,13 +167,13 @@ pullFinalMessage = do Right x -> return $ Just x -- | Extract p=q pairs from a challenge. -toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Pairs +toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Pairs toPairs ctext = case pairs ctext of Left _e -> throwError AuthOtherFailure -- TODO: Log Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. -respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Bool +respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool respond m = do r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m case r of @@ -184,7 +184,7 @@ respond m = do -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure' prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text - -> ErrorT AuthFailure (StateT Stream IO) (Text.Text, Maybe Text.Text, Text.Text) + -> ErrorT AuthFailure (StateT StreamState IO) (Text.Text, Maybe Text.Text, Text.Text) prepCredentials authcid authzid password = case credentials of Nothing -> throwError $ AuthIllegalCredentials Just creds -> return creds diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 21ea08f..7e7aca4 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -42,13 +42,13 @@ import Network.Xmpp.Sasl.Types xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> Maybe Text -- ^ Authorization identity (authcid) -> Text -- ^ Password (authzid) - -> ErrorT AuthFailure (StateT Stream IO) () + -> ErrorT AuthFailure (StateT StreamState IO) () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password Just address <- gets streamAddress xmppDigestMd5' address ac az pw where - xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) () + xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) () xmppDigestMd5' hostname authcid authzid password = do -- Push element and receive the challenge. _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index e2833ce..fa35be7 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -50,7 +50,7 @@ import Network.Xmpp.Sasl.Types xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) - -> ErrorT AuthFailure (StateT Stream IO) () + -> ErrorT AuthFailure (StateT StreamState IO) () xmppPlain authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 177ce3b..84535dc 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -49,7 +49,7 @@ scram :: (Crypto.Hash ctx hash) -> Text.Text -- ^ Authentication ID (user name) -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password - -> ErrorT AuthFailure (StateT Stream IO) () + -> ErrorT AuthFailure (StateT StreamState IO) () scram hashToken authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password scramhelper hashToken ac az pw @@ -98,7 +98,7 @@ scram hashToken authcid authzid password = do fromPairs :: Pairs -> BS.ByteString - -> ErrorT AuthFailure (StateT Stream IO) (BS.ByteString, BS.ByteString, Integer) + -> ErrorT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer) fromPairs pairs cnonce | Just nonce <- lookup "r" pairs , cnonce `BS.isPrefixOf` nonce , Just salt' <- lookup "s" pairs diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index e3273da..1e53c34 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -34,4 +34,4 @@ type Pairs = [(ByteString, ByteString)] -- | Tuple defining the SASL Handler's name, and a SASL mechanism computation. -- The SASL mechanism is a stateful @Stream@ computation, which has the -- possibility of resulting in an authentication error. -type SaslHandler = (Text.Text, StateT Stream IO (Either XmppFailure (Maybe AuthFailure))) +type SaslHandler = (Text.Text, StateT StreamState IO (Either XmppFailure (Maybe AuthFailure))) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index adb0102..86bc227 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -111,13 +111,14 @@ 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 XmppFailure -- will be produced. -startStream :: StateT Stream IO (Either XmppFailure ()) +startStream :: StateT StreamState IO (Either XmppFailure ()) startStream = runErrorT $ do lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." state <- lift $ get -- Set the `from' (which is also the expected to) attribute depending on the -- state of the stream. - let expectedTo = case (streamState state, toJid $ streamConfiguration state) of + let expectedTo = case ( streamConnectionState state + , toJid $ streamConfiguration state) of (Plain, (Just (jid, True))) -> Just jid (Secured, (Just (jid, _))) -> Just jid (Plain, Nothing) -> Nothing @@ -173,10 +174,10 @@ startStream = runErrorT $ do "Root name prefix set and not stream" | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) where - -- closeStreamWithError :: MonadIO m => TMVar Stream -> StreamErrorCondition -> + -- closeStreamWithError :: MonadIO m => Stream -> StreamErrorCondition -> -- Maybe Element -> ErrorT XmppFailure m () closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String - -> ErrorT XmppFailure (StateT Stream IO) () + -> ErrorT XmppFailure (StateT StreamState IO) () closeStreamWithError sec el msg = do lift . pushElement . pickleElem xpStreamError $ StreamErrorInfo sec Nothing el @@ -219,7 +220,7 @@ flattenAttrs attrs = Prelude.map (\(name, content) -> -- Sets a new Event source using the raw source (of bytes) -- and calls xmppStartStream. -restartStream :: StateT Stream IO (Either XmppFailure ()) +restartStream :: StateT StreamState IO (Either XmppFailure ()) restartStream = do lift $ debugM "Pontarius.XMPP" "Restarting stream..." raw <- gets (streamReceive . streamHandle) @@ -275,7 +276,7 @@ streamS expectedTo = do -- | Connects to the XMPP server and opens the XMPP stream against the given -- realm. -openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) +openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream)) openStream realm config = runErrorT $ do lift $ debugM "Pontarius.XMPP" "Opening stream..." stream' <- createStream realm config @@ -285,7 +286,7 @@ openStream realm config = runErrorT $ do -- | Send "" and wait for the server to finish processing and to -- close the connection. Any remaining elements from the server are returned. -- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. -closeStreams :: TMVar Stream -> IO (Either XmppFailure [Element]) +closeStreams :: Stream -> IO (Either XmppFailure [Element]) closeStreams = withStream closeStreams' closeStreams' = do @@ -301,7 +302,7 @@ closeStreams' = do where -- Pulls elements from the stream until the stream ends, or an error is -- raised. - collectElems :: [Element] -> StateT Stream IO (Either XmppFailure [Element]) + collectElems :: [Element] -> StateT StreamState IO (Either XmppFailure [Element]) collectElems es = do result <- pullElement case result of @@ -311,7 +312,7 @@ closeStreams' = do -- TODO: Can the TLS send/recv functions throw something other than an IO error? -wrapIOException :: IO a -> StateT Stream IO (Either XmppFailure a) +wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) wrapIOException action = do r <- liftIO $ tryIOError action case r of @@ -320,39 +321,39 @@ wrapIOException action = do lift $ warningM "Pontarius.XMPP" $ "wrapIOException: Exception wrapped: " ++ (show e) return $ Left $ XmppIOException e -pushElement :: Element -> StateT Stream IO (Either XmppFailure Bool) +pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushElement x = do send <- gets (streamSend . streamHandle) wrapIOException $ send $ renderElement x -- | Encode and send stanza -pushStanza :: Stanza -> TMVar Stream -> IO (Either XmppFailure Bool) +pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) pushStanza s = withStream' . 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 Stream IO (Either XmppFailure Bool) +pushXmlDecl :: StateT StreamState IO (Either XmppFailure Bool) pushXmlDecl = do con <- gets streamHandle wrapIOException $ (streamSend con) "" -pushOpenElement :: Element -> StateT Stream IO (Either XmppFailure Bool) +pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushOpenElement e = do sink <- gets (streamSend . streamHandle) wrapIOException $ sink $ renderOpenElement e -- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `b' value. -runEventsSink :: Sink Event IO b -> StateT Stream IO (Either XmppFailure b) +runEventsSink :: Sink Event IO b -> StateT StreamState IO (Either XmppFailure b) runEventsSink snk = do -- TODO: Wrap exceptions? src <- gets streamEventSource (src', r) <- lift $ src $$++ snk modify (\s -> s{streamEventSource = src'}) return $ Right r -pullElement :: StateT Stream IO (Either XmppFailure Element) +pullElement :: StateT StreamState IO (Either XmppFailure Element) pullElement = do ExL.catches (do e <- runEventsSink (elements =$ await) @@ -375,7 +376,7 @@ pullElement = do ] -- Pulls an element and unpickles it. -pullUnpickle :: PU [Node] a -> StateT Stream IO (Either XmppFailure a) +pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) pullUnpickle p = do elem <- pullElement case elem of @@ -389,7 +390,7 @@ pullUnpickle p = do Right r -> return $ Right r -- | Pulls a stanza (or stream error) from the stream. -pullStanza :: TMVar Stream -> IO (Either XmppFailure Stanza) +pullStanza :: Stream -> IO (Either XmppFailure Stanza) pullStanza = withStream $ do res <- pullUnpickle xpStreamStanza case res of @@ -409,9 +410,9 @@ catchPush p = ExL.catch ) -- Stream state used when there is no connection. -xmppNoStream :: Stream -xmppNoStream = Stream { - streamState = Closed +xmppNoStream :: StreamState +xmppNoStream = StreamState { + streamConnectionState = Closed , streamHandle = StreamHandle { streamSend = \_ -> return False , streamReceive = \_ -> do errorM "Pontarius.XMPP" "xmppNoStream: No stream on receive." @@ -435,7 +436,7 @@ xmppNoStream = Stream { errorM "Pontarius.XMPP" "zeroSource utilized." ExL.throwIO XmppOtherFailure -createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (TMVar Stream) +createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) createStream realm config = do result <- connect realm config case result of @@ -451,8 +452,8 @@ createStream realm config = do , streamFlush = hFlush h , streamClose = hClose h } - let stream = Stream - { streamState = Plain + let stream = StreamState + { streamConnectionState = Plain , streamHandle = hand , streamEventSource = eSource , streamFeatures = StreamFeatures Nothing [] [] @@ -644,8 +645,8 @@ srvLookup realm resolvSeed = ErrorT $ do return $ ((priority, weight, port, domain):tail) -- Closes the connection and updates the XmppConMonad Stream state. --- killStream :: TMVar Stream -> IO (Either ExL.SomeException ()) -killStream :: TMVar Stream -> IO (Either XmppFailure ()) +-- killStream :: Stream -> IO (Either ExL.SomeException ()) +killStream :: Stream -> IO (Either XmppFailure ()) killStream = withStream $ do cc <- gets (streamClose . streamHandle) err <- wrapIOException cc @@ -660,7 +661,7 @@ pushIQ :: StanzaID -> IQRequestType -> Maybe LangTag -> Element - -> TMVar Stream + -> Stream -> IO (Either XmppFailure (Either IQError IQResult)) pushIQ iqID to tp lang body stream = do pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream @@ -734,8 +735,8 @@ elements = do streamName :: Name streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) -withStream :: StateT Stream IO (Either XmppFailure c) -> TMVar Stream -> IO (Either XmppFailure c) -withStream action stream = bracketOnError +withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c) +withStream action (Stream stream) = bracketOnError (atomically $ takeTMVar stream ) (atomically . putTMVar stream) (\s -> do @@ -745,12 +746,12 @@ withStream action stream = bracketOnError ) -- nonblocking version. Changes to the connection are ignored! -withStream' :: StateT Stream IO (Either XmppFailure b) -> TMVar Stream -> IO (Either XmppFailure b) -withStream' action stream = do +withStream' :: StateT StreamState IO (Either XmppFailure b) -> Stream -> IO (Either XmppFailure b) +withStream' action (Stream stream) = do stream_ <- atomically $ readTMVar stream (r, _) <- runStateT action stream_ return r -mkStream :: Stream -> IO (TMVar Stream) -mkStream con = {- Stream `fmap` -} (atomically $ newTMVar con) +mkStream :: StreamState -> IO (Stream) +mkStream con = Stream `fmap` (atomically $ newTMVar con) diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 3748a35..71e9b8d 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -34,12 +34,12 @@ starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] -- | Checks for TLS support and run starttls procedure if applicable -tls :: TMVar Stream -> IO (Either XmppFailure ()) +tls :: Stream -> IO (Either XmppFailure ()) tls con = Ex.handle (return . Left . TlsError) . flip withStream con . runErrorT $ do conf <- gets $ streamConfiguration - sState <- gets streamState + sState <- gets streamConnectionState case sState of Plain -> return () Closed -> do @@ -79,7 +79,7 @@ tls con = Ex.handle (return . Left . TlsError) } lift $ modify ( \x -> x {streamHandle = newHand}) either (lift . Ex.throwIO) return =<< lift restartStream - modify (\s -> s{streamState = Secured}) + modify (\s -> s{streamConnectionState = Secured}) return () client params gen backend = do diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index d6c8e8c..55f048f 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -34,6 +34,7 @@ module Network.Xmpp.Types , StreamHandle(..) , Stream(..) , StreamState(..) + , ConnectionState(..) , StreamErrorInfo(..) , StreamConfiguration(..) , langTag @@ -785,7 +786,7 @@ data StreamFeatures = StreamFeatures } deriving Show -- | Signals the state of the stream connection. -data StreamState +data ConnectionState = Closed -- ^ No stream has been established | Plain -- ^ Stream established, but not secured via TLS | Secured -- ^ Stream established and secured via TLS @@ -803,9 +804,9 @@ data StreamHandle = , streamClose :: IO () } -data Stream = Stream +data StreamState = StreamState { -- | State of the stream - 'Closed', 'Plain', or 'Secured' - streamState :: !StreamState -- ^ State of connection + streamConnectionState :: !ConnectionState -- ^ State of connection -- | Functions to send, receive, flush, and close on the stream , streamHandle :: StreamHandle -- | Event conduit source, and its associated finalizer @@ -831,6 +832,8 @@ data Stream = Stream , streamConfiguration :: StreamConfiguration } +newtype Stream = Stream { unStream :: TMVar StreamState } + --------------- -- JID --------------- diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index 5dd6bf9..6430509 100644 --- a/source/Network/Xmpp/Xep/InbandRegistration.hs +++ b/source/Network/Xmpp/Xep/InbandRegistration.hs @@ -46,7 +46,7 @@ data Query = Query { instructions :: Maybe Text.Text emptyQuery = Query Nothing False False [] -query :: IQRequestType -> Query -> TMVar Stream -> IO (Either IbrError Query) +query :: IQRequestType -> Query -> Stream -> IO (Either IbrError Query) query queryType x con = do answer <- pushIQ "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con case answer of @@ -89,7 +89,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)] - -> TMVar Stream + -> Stream -> IO (Either RegisterError Query) registerWith givenFields con = runErrorT $ do fs <- mapError IbrError . ErrorT $ requestFields con @@ -121,7 +121,7 @@ deleteAccount host hostname port username password = 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 :: TMVar Stream -> IO (Either IbrError Query) +unregister :: Stream -> IO (Either IbrError Query) unregister = query Set $ emptyQuery {remove = True} unregister' :: Session -> IO (Either IbrError Query) diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index 5bcb84a..6767fd7 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -102,7 +102,7 @@ queryInfo to node context = do xmppQueryInfo :: Maybe Jid -> Maybe Text.Text - -> TMVar Stream + -> Stream -> IO (Either DiscoError QueryInfoResult) xmppQueryInfo to node con = do res <- pushIQ "info" to Get Nothing queryBody con