Browse Source

stream id now stored in connection state

master
Jon Kristensen 14 years ago
parent
commit
f53abf0176
  1. 30
      source/Network/Xmpp/Monad.hs
  2. 24
      source/Network/Xmpp/Stream.hs
  3. 2
      source/Network/Xmpp/Types.hs

30
source/Network/Xmpp/Monad.hs

@ -107,20 +107,21 @@ catchPush p = Ex.catch
-- XmppConnection state used when there is no connection. -- XmppConnection state used when there is no connection.
xmppNoConnection :: XmppConnection xmppNoConnection :: XmppConnection
xmppNoConnection = XmppConnection xmppNoConnection = XmppConnection
{ sConSrc = zeroSource { sConSrc = zeroSource
, sRawSrc = zeroSource , sRawSrc = zeroSource
, sConPushBS = \_ -> return False -- Nothing has been sent. , sConPushBS = \_ -> return False -- Nothing has been sent.
, sConHandle = Nothing , sConHandle = Nothing
, sFeatures = SF Nothing [] [] , sFeatures = SF Nothing [] []
, sConnectionState = XmppConnectionClosed , sConnectionState = XmppConnectionClosed
, sHostname = Nothing , sHostname = Nothing
, sJid = Nothing , sJid = Nothing
, sCloseConnection = return () , sCloseConnection = return ()
, sStreamLang = Nothing , sStreamLang = Nothing
, sPreferredLang = Nothing , sStreamId = Nothing
, sToJid = Nothing , sPreferredLang = Nothing
, sJidWhenPlain = False , sToJid = Nothing
, sFrom = Nothing , sJidWhenPlain = False
, sFrom = Nothing
} }
where where
zeroSource :: Source IO output zeroSource :: Source IO output
@ -148,6 +149,7 @@ xmppRawConnect host hostname = do
, sCloseConnection = (hClose con) , sCloseConnection = (hClose con)
, sPreferredLang = Nothing -- TODO: Allow user to set , sPreferredLang = Nothing -- TODO: Allow user to set
, sStreamLang = Nothing , sStreamLang = Nothing
, sStreamId = Nothing
, sToJid = Nothing -- TODO: Allow user to set , sToJid = Nothing -- TODO: Allow user to set
, sJidWhenPlain = False -- TODO: Allow user to set , sJidWhenPlain = False -- TODO: Allow user to set
, sFrom = Nothing , sFrom = Nothing

24
source/Network/Xmpp/Stream.hs

@ -75,8 +75,13 @@ xmppStartStream = runErrorT $ do
, Just hostname , Just hostname
, sPreferredLang state , sPreferredLang state
) )
(lt, from, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream to (lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream to
modify (\s -> s {sFeatures = features, sStreamLang = Just lt, sFrom = from}) modify (\s -> s { sFeatures = features
, sStreamLang = Just lt
, sStreamId = id
, sFrom = from
}
)
return () return ()
-- Creates a new connection source (of Events) using the raw source (of bytes) -- Creates a new connection source (of Events) using the raw source (of bytes)
@ -91,13 +96,17 @@ xmppRestartStream = do
-- Reads the (partial) stream:stream and the server features from the stream. -- Reads the (partial) stream:stream and the server features from the stream.
-- Also validates the stream element's attributes and throws an error if -- Also validates the stream element's attributes and throws an error if
-- appropriate. -- appropriate.
xmppStream :: Maybe Jid -> StreamSink (LangTag, Maybe Text, ServerFeatures) -- TODO: from.
xmppStream :: Maybe Jid -> StreamSink ( LangTag
, Maybe Text
, Maybe Text
, ServerFeatures)
xmppStream expectedTo = do xmppStream expectedTo = do
(langTag, from) <- xmppStreamHeader (langTag, from, id) <- xmppStreamHeader
features <- xmppStreamFeatures features <- xmppStreamFeatures
return (langTag, from, features) return (langTag, from, id, features)
where where
xmppStreamHeader :: StreamSink (LangTag, Maybe Text) xmppStreamHeader :: StreamSink (LangTag, Maybe Text, Maybe Text)
xmppStreamHeader = do xmppStreamHeader = do
lift throwOutJunk lift throwOutJunk
-- Get the stream:stream element (or whatever it is) from the server, -- Get the stream:stream element (or whatever it is) from the server,
@ -109,10 +118,9 @@ xmppStream expectedTo = do
unless (prefix == Just "stream") $ throwError $ StreamInvalidStreamPrefix prefix unless (prefix == Just "stream") $ throwError $ StreamInvalidStreamPrefix prefix
unless (isNothing to || (fromText $ fromJust to) == expectedTo) $ throwError $ StreamWrongTo to unless (isNothing to || (fromText $ fromJust to) == expectedTo) $ throwError $ StreamWrongTo to
unless (ver == Just "1.0") $ throwError $ StreamWrongVersion ver unless (ver == Just "1.0") $ throwError $ StreamWrongVersion ver
-- TODO: Verify id and from.
let lang_ = maybe Nothing langTag lang let lang_ = maybe Nothing langTag lang
when (isNothing lang_) $ throwError $ StreamWrongLangTag lang when (isNothing lang_) $ throwError $ StreamWrongLangTag lang
return (fromJust lang_, from) return (fromJust lang_, from, id)
xmppStreamFeatures :: StreamSink ServerFeatures xmppStreamFeatures :: StreamSink ServerFeatures
xmppStreamFeatures = do xmppStreamFeatures = do
e <- lift $ elements =$ CL.head e <- lift $ elements =$ CL.head

2
source/Network/Xmpp/Types.hs

@ -749,6 +749,8 @@ data XmppConnection = XmppConnection
, sStreamLang :: Maybe LangTag -- Will be a `Just' value , sStreamLang :: Maybe LangTag -- Will be a `Just' value
-- once connected to the -- once connected to the
-- server. -- server.
, sStreamId :: Maybe Text -- Stream ID as specified by the
-- server.
, sToJid :: Maybe Jid -- JID to include in the stream , sToJid :: Maybe Jid -- JID to include in the stream
-- element's `to' attribute when -- element's `to' attribute when
-- the connection is secured. See -- the connection is secured. See

Loading…
Cancel
Save