Browse Source

wrap the stream object (TMVar Stream) in a newtype

rename StreamState to ConnectionState
rename Stream to StreamState
add Stream newtype
master
Philipp Balzarek 13 years ago
parent
commit
e318696981
  1. 2
      source/Network/Xmpp/Concurrent.hs
  2. 12
      source/Network/Xmpp/Concurrent/Threads.hs
  3. 2
      source/Network/Xmpp/Concurrent/Types.hs
  4. 10
      source/Network/Xmpp/Sasl.hs
  5. 20
      source/Network/Xmpp/Sasl/Common.hs
  6. 4
      source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
  7. 2
      source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
  8. 4
      source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
  9. 2
      source/Network/Xmpp/Sasl/Types.hs
  10. 65
      source/Network/Xmpp/Stream.hs
  11. 6
      source/Network/Xmpp/Tls.hs
  12. 9
      source/Network/Xmpp/Types.hs
  13. 6
      source/Network/Xmpp/Xep/InbandRegistration.hs
  14. 2
      source/Network/Xmpp/Xep/ServiceDiscovery.hs

2
source/Network/Xmpp/Concurrent.hs

@ -90,7 +90,7 @@ toChans stanzaC outC iqHands sta = atomically $ do @@ -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

12
source/Network/Xmpp/Concurrent/Threads.hs

@ -29,7 +29,7 @@ import System.Log.Logger @@ -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 = @@ -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 = @@ -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

2
source/Network/Xmpp/Concurrent/Types.hs

@ -44,7 +44,7 @@ data Session = Session @@ -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

10
source/Network/Xmpp/Sasl.hs

@ -66,7 +66,7 @@ import Control.Monad.Error @@ -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 @@ -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 @@ -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 $ @@ -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" @@ -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

20
source/Network/Xmpp/Sasl/Common.hs

@ -31,7 +31,7 @@ import qualified System.Random as Random @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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

4
source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs

@ -42,13 +42,13 @@ import Network.Xmpp.Sasl.Types @@ -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?

2
source/Network/Xmpp/Sasl/Mechanisms/Plain.hs

@ -50,7 +50,7 @@ import Network.Xmpp.Sasl.Types @@ -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)

4
source/Network/Xmpp/Sasl/Mechanisms/Scram.hs

@ -49,7 +49,7 @@ scram :: (Crypto.Hash ctx hash) @@ -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 @@ -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

2
source/Network/Xmpp/Sasl/Types.hs

@ -34,4 +34,4 @@ type Pairs = [(ByteString, ByteString)] @@ -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)))

65
source/Network/Xmpp/Stream.hs

@ -111,13 +111,14 @@ openElementFromEvents = do @@ -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 @@ -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) -> @@ -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 @@ -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 @@ -285,7 +286,7 @@ openStream realm config = runErrorT $ do
-- | Send "</stream:stream>" 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 @@ -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 @@ -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 @@ -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) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
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 @@ -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 @@ -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 @@ -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 { @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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)

6
source/Network/Xmpp/Tls.hs

@ -34,12 +34,12 @@ starttlsE :: Element @@ -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) @@ -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

9
source/Network/Xmpp/Types.hs

@ -34,6 +34,7 @@ module Network.Xmpp.Types @@ -34,6 +34,7 @@ module Network.Xmpp.Types
, StreamHandle(..)
, Stream(..)
, StreamState(..)
, ConnectionState(..)
, StreamErrorInfo(..)
, StreamConfiguration(..)
, langTag
@ -785,7 +786,7 @@ data StreamFeatures = StreamFeatures @@ -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 = @@ -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 @@ -831,6 +832,8 @@ data Stream = Stream
, streamConfiguration :: StreamConfiguration
}
newtype Stream = Stream { unStream :: TMVar StreamState }
---------------
-- JID
---------------

6
source/Network/Xmpp/Xep/InbandRegistration.hs

@ -46,7 +46,7 @@ data Query = Query { instructions :: Maybe Text.Text @@ -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) @@ -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 @@ -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)

2
source/Network/Xmpp/Xep/ServiceDiscovery.hs

@ -102,7 +102,7 @@ queryInfo to node context = do @@ -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

Loading…
Cancel
Save