Browse Source

Renamed some stream-related record fields

Prefixed the fields with `stream'. `ServerFeatures' was renamed
`StreamFeatures' to be more coherent with the terminology in RFC 6120.
master
Jon Kristensen 13 years ago
parent
commit
9eb793e1d3
  1. 4
      source/Network/Xmpp/Concurrent/Threads.hs
  2. 2
      source/Network/Xmpp/Internal.hs
  3. 6
      source/Network/Xmpp/Marshal.hs
  4. 6
      source/Network/Xmpp/Sasl.hs
  5. 2
      source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
  6. 119
      source/Network/Xmpp/Stream.hs
  7. 28
      source/Network/Xmpp/Tls.hs
  8. 77
      source/Network/Xmpp/Types.hs

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

@ -37,7 +37,7 @@ readWorker onStanza onConnectionClosed stateRef = @@ -37,7 +37,7 @@ readWorker onStanza onConnectionClosed stateRef =
-- necessarily be interruptible
s <- atomically $ do
con <- readTMVar stateRef
state <- cState <$> readTMVar con
state <- streamState <$> readTMVar con
when (state == Closed)
retry
return con
@ -83,7 +83,7 @@ startThreadsWith :: (Stanza -> IO ()) @@ -83,7 +83,7 @@ startThreadsWith :: (Stanza -> IO ())
TMVar (TMVar Stream),
ThreadId))
startThreadsWith stanzaHandler eh con = do
read <- withStream' (gets $ cSend . cHandle >>= \d -> return $ Right d) con
read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con
case read of
Left e -> return $ Left e
Right read' -> do

2
source/Network/Xmpp/Internal.hs

@ -20,7 +20,7 @@ module Network.Xmpp.Internal @@ -20,7 +20,7 @@ module Network.Xmpp.Internal
( Stream(..)
, StreamState(..)
, StreamHandle(..)
, ServerFeatures(..)
, StreamFeatures(..)
, openStream
, withStream
, startTls

6
source/Network/Xmpp/Marshal.hs

@ -253,10 +253,10 @@ xpStream = xpElemAttrs @@ -253,10 +253,10 @@ xpStream = xpElemAttrs
)
-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
xpStreamFeatures :: PU [Node] ServerFeatures
xpStreamFeatures :: PU [Node] StreamFeatures
xpStreamFeatures = xpWrap
(\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
(\(SF tls sasl rest) -> (tls, lmb sasl, rest))
(\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest)
(\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest))
(xpElemNodes
(Name
"features"

6
source/Network/Xmpp/Sasl.hs

@ -71,11 +71,11 @@ xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their @@ -71,11 +71,11 @@ xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their
xmppSasl handlers = withStream $ do
-- Chooses the first mechanism that is acceptable by both the client and the
-- server.
mechanisms <- gets $ saslMechanisms . cFeatures
mechanisms <- gets $ streamSaslMechanisms . streamFeatures
case (filter (\(name, _) -> name `elem` mechanisms)) handlers of
[] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms
(_name, handler):_ -> do
cs <- gets cState
cs <- gets streamState
case cs of
Closed -> return . Right $ Just AuthNoStream
_ -> do
@ -134,7 +134,7 @@ xmppBind rsrc c = runErrorT $ do @@ -134,7 +134,7 @@ xmppBind rsrc c = runErrorT $ do
case jid of
Right jid' -> do
ErrorT $ withStream (do
modify $ \s -> s{cJid = Just jid'}
modify $ \s -> s{streamJid = Just jid'}
return $ Right jid') c -- not pretty
return jid'
otherwise -> throwError XmppOtherFailure

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

@ -45,7 +45,7 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) @@ -45,7 +45,7 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username)
-> SaslM ()
xmppDigestMd5 authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password
hn <- gets cHostName
hn <- gets streamHostname
xmppDigestMd5' (fromJust hn) ac az pw
where
xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM ()

119
source/Network/Xmpp/Stream.hs

@ -1,4 +1,5 @@ @@ -1,4 +1,5 @@
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -92,11 +93,11 @@ startStream = runErrorT $ do @@ -92,11 +93,11 @@ startStream = runErrorT $ do
stream <- liftIO $ mkStream state
-- Set the `from' (which is also the expected to) attribute depending on the
-- state of the stream.
let expectedTo = case cState state of
Plain -> if cJidWhenPlain state
then cJid state else Nothing
Secured -> cJid state
case cHostName state of
let expectedTo = case streamState state of
Plain -> if includeJidWhenPlain state
then toJid state else Nothing
Secured -> toJid state
case streamHostname state of
Nothing -> throwError XmppOtherFailure -- TODO: When does this happen?
Just hostname -> lift $ do
pushXmlDecl
@ -105,7 +106,7 @@ startStream = runErrorT $ do @@ -105,7 +106,7 @@ startStream = runErrorT $ do
, expectedTo
, Just (Jid Nothing hostname Nothing)
, Nothing
, cPreferredLang state
, preferredLang state
)
response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo
case response of
@ -117,15 +118,15 @@ startStream = runErrorT $ do @@ -117,15 +118,15 @@ startStream = runErrorT $ do
| lt == Nothing ->
closeStreamWithError stream StreamInvalidXml Nothing
-- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead?
| isJust from && (from /= Just (Jid Nothing (fromJust $ cHostName state) Nothing)) ->
| isJust from && (from /= Just (Jid Nothing (fromJust $ streamHostname state) Nothing)) ->
closeStreamWithError stream StreamInvalidFrom Nothing
| to /= expectedTo ->
closeStreamWithError stream StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable?
| otherwise -> do
modify (\s -> s{ cFeatures = features
, cStreamLang = lt
, cStreamId = id
, cFrom = from
modify (\s -> s{ streamFeatures = features
, streamLang = lt
, streamId = id
, streamFrom = from
} )
return ()
-- Unpickling failed - we investigate the element.
@ -180,10 +181,10 @@ flattenAttrs attrs = Prelude.map (\(name, content) -> @@ -180,10 +181,10 @@ flattenAttrs attrs = Prelude.map (\(name, content) ->
-- and calls xmppStartStream.
restartStream :: StateT Stream IO (Either XmppFailure ())
restartStream = do
raw <- gets (cRecv . cHandle)
raw <- gets (streamReceive . streamHandle)
let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def)
(return ())
modify (\s -> s{cEventSource = newSource })
modify (\s -> s{streamEventSource = newSource })
startStream
where
loopRead read = do
@ -203,7 +204,7 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text @@ -203,7 +204,7 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text
, Maybe Jid
, Maybe Text
, Maybe LangTag
, ServerFeatures ))
, StreamFeatures ))
streamS expectedTo = do
header <- xmppStreamHeader
case header of
@ -222,7 +223,7 @@ streamS expectedTo = do @@ -222,7 +223,7 @@ streamS expectedTo = do
case unpickleElem xpStream el of
Left _ -> return $ Left el
Right r -> return $ Right r
xmppStreamFeatures :: StreamSink ServerFeatures
xmppStreamFeatures :: StreamSink StreamFeatures
xmppStreamFeatures = do
e <- lift $ elements =$ CL.head
case e of
@ -246,8 +247,8 @@ openStream address port hostname = do @@ -246,8 +247,8 @@ openStream address port hostname = do
-- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError.
closeStreams :: TMVar Stream -> IO (Either XmppFailure [Element])
closeStreams = withStream $ do
send <- gets (cSend . cHandle)
cc <- gets (cClose . cHandle)
send <- gets (streamSend . streamHandle)
cc <- gets (streamClose . streamHandle)
liftIO $ send "</stream:stream>"
void $ liftIO $ forkIO $ do
threadDelay 3000000 -- TODO: Configurable value
@ -282,7 +283,7 @@ wrapIOException action = do @@ -282,7 +283,7 @@ wrapIOException action = do
pushElement :: Element -> StateT Stream IO (Either XmppFailure Bool)
pushElement x = do
send <- gets (cSend . cHandle)
send <- gets (streamSend . streamHandle)
wrapIOException $ send $ renderElement x
-- | Encode and send stanza
@ -295,21 +296,21 @@ pushStanza s = withStream' . pushElement $ pickleElem xpStanza s @@ -295,21 +296,21 @@ pushStanza s = withStream' . pushElement $ pickleElem xpStanza s
-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0.
pushXmlDecl :: StateT Stream IO (Either XmppFailure Bool)
pushXmlDecl = do
con <- gets cHandle
wrapIOException $ (cSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
con <- gets streamHandle
wrapIOException $ (streamSend con) "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
pushOpenElement :: Element -> StateT Stream IO (Either XmppFailure Bool)
pushOpenElement e = do
sink <- gets (cSend . cHandle)
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 snk = do -- TODO: Wrap exceptions?
source <- gets cEventSource
source <- gets streamEventSource
(src', r) <- lift $ source $$++ snk
modify (\s -> s{cEventSource = src'})
modify (\s -> s{streamEventSource = src'})
return $ Right r
pullElement :: StateT Stream IO (Either XmppFailure Element)
@ -362,25 +363,25 @@ catchPush p = ExL.catch @@ -362,25 +363,25 @@ catchPush p = ExL.catch
-- Stream state used when there is no connection.
xmppNoStream :: Stream
xmppNoStream = Stream
{ cHandle = StreamHandle { cSend = \_ -> return False
, cRecv = \_ -> ExL.throwIO
XmppOtherFailure
, cFlush = return ()
, cClose = return ()
}
, cEventSource = DCI.ResumableSource zeroSource (return ())
, cFeatures = SF Nothing [] []
, cState = Closed
, cHostName = Nothing
, cJid = Nothing
, cStreamLang = Nothing
, cStreamId = Nothing
, cPreferredLang = Nothing
, cToJid = Nothing
, cJidWhenPlain = False
, cFrom = Nothing
}
xmppNoStream = Stream {
streamState = Closed
, streamHandle = StreamHandle { streamSend = \_ -> return False
, streamReceive = \_ -> ExL.throwIO
XmppOtherFailure
, streamFlush = return ()
, streamClose = return ()
}
, streamEventSource = DCI.ResumableSource zeroSource (return ())
, streamFeatures = StreamFeatures Nothing [] []
, streamHostname = Nothing
, streamFrom = Nothing
, streamId = Nothing
, streamLang = Nothing
, streamJid = Nothing
, preferredLang = Nothing
, toJid = Nothing
, includeJidWhenPlain = False
}
where
zeroSource :: Source IO output
zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure
@ -396,35 +397,35 @@ connectTcp host port hostname = do @@ -396,35 +397,35 @@ connectTcp host port hostname = do
let eSource = DCI.ResumableSource
((sourceHandle h $= logConduit) $= XP.parseBytes def)
(return ())
let hand = StreamHandle { cSend = \d -> do
let hand = StreamHandle { streamSend = \d -> do
let d64 = encode d
debugM "Pontarius.Xmpp" $
"Sending TCP data: " ++ (BSC8.unpack d64)
++ "."
catchPush $ BS.hPut h d
, cRecv = \n -> do
, streamReceive = \n -> do
d <- BS.hGetSome h n
let d64 = encode d
debugM "Pontarius.Xmpp" $
"Received TCP data: " ++
(BSC8.unpack d64) ++ "."
return d
, cFlush = hFlush h
, cClose = hClose h
, streamFlush = hFlush h
, streamClose = hClose h
}
let stream = Stream
{ cHandle = hand
, cEventSource = eSource
, cFeatures = (SF Nothing [] [])
, cState = Plain
, cHostName = (Just hostname)
, cJid = Nothing
, cPreferredLang = Nothing -- TODO: Allow user to set
, cStreamLang = Nothing
, cStreamId = Nothing
, cToJid = Nothing -- TODO: Allow user to set
, cJidWhenPlain = False -- TODO: Allow user to set
, cFrom = Nothing
{ streamState = Plain
, streamHandle = hand
, streamEventSource = eSource
, streamFeatures = StreamFeatures Nothing [] []
, streamHostname = (Just hostname)
, streamFrom = Nothing
, streamId = Nothing
, streamLang = Nothing
, streamJid = Nothing
, preferredLang = Nothing -- TODO: Allow user to set
, toJid = Nothing -- TODO: Allow user to set
, includeJidWhenPlain = False -- TODO: Allow user to set
}
stream' <- mkStream stream
return $ Right stream'
@ -441,7 +442,7 @@ connectTcp host port hostname = do @@ -441,7 +442,7 @@ connectTcp host port hostname = do
-- killStream :: TMVar Stream -> IO (Either ExL.SomeException ())
killStream :: TMVar Stream -> IO (Either XmppFailure ())
killStream = withStream $ do
cc <- gets (cClose . cHandle)
cc <- gets (streamClose . streamHandle)
err <- wrapIOException cc
-- (ExL.try cc :: IO (Either ExL.SomeException ()))
put xmppNoStream

28
source/Network/Xmpp/Tls.hs

@ -22,10 +22,10 @@ import Network.Xmpp.Types @@ -22,10 +22,10 @@ import Network.Xmpp.Types
import Control.Concurrent.STM.TMVar
mkBackend con = Backend { backendSend = \bs -> void (cSend con bs)
, backendRecv = cRecv con
, backendFlush = cFlush con
, backendClose = cClose con
mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)
, backendRecv = streamReceive con
, backendFlush = streamFlush con
, backendClose = streamClose con
}
where
cutBytes n = do
@ -78,14 +78,14 @@ startTls :: TLS.TLSParams -> TMVar Stream -> IO (Either XmppFailure ()) @@ -78,14 +78,14 @@ startTls :: TLS.TLSParams -> TMVar Stream -> IO (Either XmppFailure ())
startTls params con = Ex.handle (return . Left . TlsError)
. flip withStream con
. runErrorT $ do
features <- lift $ gets cFeatures
state <- gets cState
features <- lift $ gets streamFeatures
state <- gets streamState
case state of
Plain -> return ()
Closed -> throwError XmppNoStream
Secured -> throwError TlsStreamSecured
con <- lift $ gets cHandle
when (stls features == Nothing) $ throwError TlsNoServerSupport
con <- lift $ gets streamHandle
when (streamTls features == Nothing) $ throwError TlsNoServerSupport
lift $ pushElement starttlsE
answer <- lift $ pullElement
case answer of
@ -93,12 +93,12 @@ startTls params con = Ex.handle (return . Left . TlsError) @@ -93,12 +93,12 @@ startTls params con = Ex.handle (return . Left . TlsError)
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right ()
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> return $ Left XmppOtherFailure
(raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con)
let newHand = StreamHandle { cSend = catchPush . psh
, cRecv = read
, cFlush = contextFlush ctx
, cClose = bye ctx >> cClose con
let newHand = StreamHandle { streamSend = catchPush . psh
, streamReceive = read
, streamFlush = contextFlush ctx
, streamClose = bye ctx >> streamClose con
}
lift $ modify ( \x -> x {cHandle = newHand})
lift $ modify ( \x -> x {streamHandle = newHand})
either (lift . Ex.throwIO) return =<< lift restartStream
modify (\s -> s{cState = Secured})
modify (\s -> s{streamState = Secured})
return ()

77
source/Network/Xmpp/Types.hs

@ -22,7 +22,7 @@ module Network.Xmpp.Types @@ -22,7 +22,7 @@ module Network.Xmpp.Types
, PresenceType(..)
, SaslError(..)
, SaslFailure(..)
, ServerFeatures(..)
, StreamFeatures(..)
, Stanza(..)
, StanzaError(..)
, StanzaErrorCondition(..)
@ -755,52 +755,63 @@ langTagParser = do @@ -755,52 +755,63 @@ langTagParser = do
tagChars :: [Char]
tagChars = ['a'..'z'] ++ ['A'..'Z']
data ServerFeatures = SF
{ stls :: !(Maybe Bool)
, saslMechanisms :: ![Text.Text]
, other :: ![Element]
data StreamFeatures = StreamFeatures
{ streamTls :: !(Maybe Bool)
, streamSaslMechanisms :: ![Text.Text]
, streamOtherFeatures :: ![Element] -- TODO: All feature elements instead?
} deriving Show
-- | Signals the state of the connection.
-- | Signals the state of the stream connection.
data StreamState
= Closed -- ^ No stream at this point.
| Plain -- ^ Stream established, but not secured.
| Secured -- ^ Stream established and secured via TLS.
= Closed -- ^ No stream has been established
| Plain -- ^ Stream established, but not secured via TLS
| Secured -- ^ Stream established and secured via TLS
deriving (Show, Eq, Typeable)
-- | Defines operations for sending, receiving, flushing, and closing on a
-- connection.
-- stream.
data StreamHandle =
StreamHandle { cSend :: BS.ByteString -> IO Bool
, cRecv :: Int -> IO BS.ByteString
-- This is to hold the state of the XML parser (otherwise
-- we will receive EventBeginDocument events and forget
-- about name prefixes).
, cFlush :: IO ()
, cClose :: IO ()
StreamHandle { streamSend :: BS.ByteString -> IO Bool
, streamReceive :: Int -> IO BS.ByteString
-- This is to hold the state of the XML parser (otherwise we
-- will receive EventBeginDocument events and forget about
-- name prefixes). (TODO: Clarify)
, streamFlush :: IO ()
, streamClose :: IO ()
}
data Stream = Stream
{ cState :: !StreamState -- ^ State of connection
, cHandle :: StreamHandle -- ^ Handle to send, receive, flush, and close
-- on the connection.
, cEventSource :: ResumableSource IO Event -- ^ Event conduit source, and
-- its associated finalizer
, cFeatures :: !ServerFeatures -- ^ Features as advertised by the server
, cHostName :: !(Maybe Text) -- ^ Hostname of the server
, cJid :: !(Maybe Jid) -- ^ Our JID
, cPreferredLang :: !(Maybe LangTag) -- ^ Default language when no explicit
{ -- | State of the stream - 'Closed', 'Plain', or 'Secured'
streamState :: !StreamState -- ^ State of connection
-- | Functions to send, receive, flush, and close on the stream
, streamHandle :: StreamHandle
-- | Event conduit source, and its associated finalizer
, streamEventSource :: ResumableSource IO Event
-- | Stream features advertised by the server
, streamFeatures :: !StreamFeatures -- TODO: Maybe?
-- | The hostname we specified for the connection
, streamHostname :: !(Maybe Text)
-- | The hostname specified in the server's stream element's
-- `from' attribute
, streamFrom :: !(Maybe Jid)
-- | The identifier specified in the server's stream element's
-- `id' attribute
, streamId :: !(Maybe Text)
-- | The language tag value specified in the server's stream
-- element's `langtag' attribute; will be a `Just' value once
-- connected to the server
-- TODO: Verify
, streamLang :: !(Maybe LangTag)
-- | Our JID as assigned by the server
, streamJid :: !(Maybe Jid)
-- TODO: Move the below fields to a configuration record
, preferredLang :: !(Maybe LangTag) -- ^ Default language when no explicit
-- language tag is set
, cStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just' value once connected
-- to the server.
, cStreamId :: !(Maybe Text) -- ^ Stream ID as specified by the server.
, cToJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to'
, toJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to'
-- attribute when the connection is secured. See
-- also below.
, cJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when
, includeJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when
-- the connection is plain.
, cFrom :: !(Maybe Jid) -- ^ From as specified by the server in the stream
-- element's `from' attribute.
}
withStream :: StateT Stream IO (Either XmppFailure c) -> TMVar Stream -> IO (Either XmppFailure c)

Loading…
Cancel
Save