From 425920646694c0c09d7a5451a1d6728059617708 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Tue, 19 Feb 2013 19:00:45 +0100 Subject: [PATCH] Add `StreamSettings' record with `Default' instance --- source/Network/Xmpp/Concurrent.hs | 3 ++- source/Network/Xmpp/Internal.hs | 1 + source/Network/Xmpp/Stream.hs | 29 +++++++++++++---------------- source/Network/Xmpp/Types.hs | 29 +++++++++++++++++++++-------- 4 files changed, 37 insertions(+), 25 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index b6df58c..421919b 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -45,6 +45,7 @@ import Network.Xmpp.Stream import Network.Xmpp.Utilities import Control.Monad.Error +import Data.Default toChans :: TChan Stanza -> TVar IQHandlers @@ -139,7 +140,7 @@ session :: HostName -- ^ Host to connect to -- the server decide) -> IO (Either XmppFailure (Session, Maybe AuthFailure)) session hostname realm port tls sasl = runErrorT $ do - con <- ErrorT $ openStream hostname port realm + con <- ErrorT $ openStream hostname port realm def if isJust tls then ErrorT $ startTls (fromJust tls) con else return () diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs index 242a169..6f596d9 100644 --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -18,6 +18,7 @@ module Network.Xmpp.Internal ( Stream(..) + , StreamConfiguration(..) , StreamState(..) , StreamHandle(..) , StreamFeatures(..) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 3b13cfb..3768080 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -104,10 +104,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 streamState state of - Plain -> if includeJidWhenPlain state - then toJid state else Nothing - Secured -> toJid state + let expectedTo = case (streamState state, toJid $ streamConfiguration state) of + (Plain, (Just (jid, True))) -> Just jid + (Secured, (Just (jid, _))) -> Just jid + (Plain, Nothing) -> Nothing + (Secured, Nothing) -> Nothing case streamHostname state of Nothing -> throwError XmppOtherFailure -- TODO: When does this happen? Just hostname -> lift $ do @@ -117,7 +118,7 @@ startStream = runErrorT $ do , expectedTo , Just (Jid Nothing hostname Nothing) , Nothing - , preferredLang state + , preferredLang $ streamConfiguration state ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of @@ -243,9 +244,9 @@ streamS expectedTo = do -- | Connects to the XMPP server and opens the XMPP stream against the given -- host name, port, and realm. -openStream :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Stream)) -openStream address port hostname = do - stream <- connectTcp address port hostname +openStream :: HostName -> PortID -> Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) +openStream address port hostname config = do + stream <- connectTcp address port hostname config case stream of Right stream' -> do result <- withStream startStream stream' @@ -389,16 +390,14 @@ xmppNoStream = Stream { , streamId = Nothing , streamLang = Nothing , streamJid = Nothing - , preferredLang = Nothing - , toJid = Nothing - , includeJidWhenPlain = False + , streamConfiguration = StreamConfiguration Nothing Nothing } where zeroSource :: Source IO output zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure -connectTcp :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Stream)) -connectTcp host port hostname = do +connectTcp :: HostName -> PortID -> Text -> StreamConfiguration -> IO (Either XmppFailure (TMVar Stream)) +connectTcp host port hostname config = do let PortNumber portNumber = port debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++ (show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "." @@ -434,9 +433,7 @@ connectTcp host port hostname = do , 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 + , streamConfiguration = config } stream' <- mkStream stream return $ Right stream' diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 6cfd51b..694fe1a 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -35,6 +35,7 @@ module Network.Xmpp.Types , Stream(..) , StreamState(..) , StreamErrorInfo(..) + , StreamConfiguration(..) , langTag , Jid(..) , isBare @@ -77,6 +78,8 @@ import Data.String (IsString(..)) import qualified Text.NamePrep as SP import qualified Text.StringPrep as SP +import Data.Default + -- | -- Wraps a string of random characters that, when using an appropriate -- @IdGenerator@, is guaranteed to be unique for the Xmpp session. @@ -809,14 +812,8 @@ data Stream = Stream , 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 - , toJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to' - -- attribute when the connection is secured. See - -- also below. - , includeJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when - -- the connection is plain. + -- | Configuration settings for the stream + , streamConfiguration :: StreamConfiguration } --------------- @@ -1010,3 +1007,19 @@ instance Exception StreamEnd data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) instance Exception InvalidXmppXml + +data StreamConfiguration = + StreamConfiguration { -- | Default language when no language tag is set + preferredLang :: !(Maybe LangTag) + -- | JID to include in the stream element's `to' + -- attribute when the connection is secured; if the + -- boolean is set to 'True', then the JID is also + -- included when the 'ConnectionState' is 'Plain' + , toJid :: !(Maybe (Jid, Bool)) + } + + +instance Default StreamConfiguration where + def = StreamConfiguration { preferredLang = Nothing + , toJid = Nothing + }