From 1030940ee6ee9baa0aff4fdefc12c9fdd9fbd3c9 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 16 Nov 2015 15:05:21 +0100 Subject: [PATCH] Send session element depending on stream features Fixes #94 --- pontarius-xmpp.cabal | 2 +- source/Network/Xmpp/Concurrent.hs | 4 ++-- source/Network/Xmpp/Lens.hs | 5 ----- source/Network/Xmpp/Marshal.hs | 15 ++++++++++----- source/Network/Xmpp/Sasl.hs | 11 +++++++++-- source/Network/Xmpp/Types.hs | 9 +++++---- 6 files changed, 27 insertions(+), 19 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 89b14e0..328bc62 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -48,7 +48,7 @@ Library , cryptohash-cryptoapi >=0.1 , data-default >=0.2 , dns >=0.3.0 - , exceptions >= 0.6 + , exceptions >=0.6 , hslogger >=1.1.0 , iproute >=1.2.4 , lens-family diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 09a1d9e..30ec7d4 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -207,8 +207,8 @@ newSession stream config realm mbSasl = runErrorT $ do , sSaslCredentials = mbSasl , reconnectWait = rew } - liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler = - onConnectionClosed config sess } + liftIO . atomically $ putTMVar eh $ + EventHandlers { connectionClosedHandler = onConnectionClosed config sess } -- Pass the new session to the plugins so they can "tie the knot" liftIO . forM_ ps $ \p -> onSessionUp p sess return sess diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index be5bdcf..22da900 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -83,7 +83,6 @@ module Network.Xmpp.Lens , toJidL , connectionDetailsL , resolvConfL - , establishSessionL , tlsBehaviourL , tlsParamsL -- **** TLS parameters @@ -489,10 +488,6 @@ resolvConfL :: Lens StreamConfiguration ResolvConf resolvConfL inj sc@StreamConfiguration{resolvConf = x} = (\x' -> sc{resolvConf = x'}) <$> inj x -establishSessionL :: Lens StreamConfiguration Bool -establishSessionL inj sc@StreamConfiguration{establishSession = x} - = (\x' -> sc{establishSession = x'}) <$> inj x - tlsBehaviourL :: Lens StreamConfiguration TlsBehaviour tlsBehaviourL inj sc@StreamConfiguration{tlsBehaviour = x} = (\x' -> sc{tlsBehaviour = x'}) <$> inj x diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 6f96b38..7d3e89d 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -350,21 +350,22 @@ xpStream = xpElemAttrs -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. xpStreamFeatures :: PU [Node] StreamFeatures xpStreamFeatures = ("xpStreamFeatures","") xpWrap - (\(tls, sasl, ver, preAppr, rest) - -> StreamFeatures tls (mbl sasl) ver preAppr rest) - (\(StreamFeatures tls sasl ver preAppr rest) - -> (tls, lmb sasl, ver, preAppr, rest)) + (\(tls, sasl, ver, preAppr, session, rest) + -> StreamFeatures tls (mbl sasl) ver preAppr session rest ) + (\(StreamFeatures tls sasl ver preAppr session rest) + -> (tls, lmb sasl, ver, preAppr, session, rest)) (xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream") ) - (xp5Tuple + (xp6Tuple (xpOption pickleTlsFeature) (xpOption pickleSaslFeature) (xpOption pickleRosterVer) picklePreApproval + (xpOption pickleSessionFeature) (xpAll xpElemVerbatim) ) ) @@ -381,6 +382,10 @@ xpStreamFeatures = ("xpStreamFeatures","") xpWrap pickleRosterVer = xpElemNodes "{urn:xmpp:features:rosterver}ver" $ xpElemExists "{urn:xmpp:features:rosterver}optional" picklePreApproval = xpElemExists "{urn:xmpp:features:pre-approval}sub" + pickleSessionFeature :: PU [Node] Bool + pickleSessionFeature = ("pickleSessionFeature", "") + xpElemNodes "{urn:ietf:params:xml:ns:xmpp-session}session" + (xpElemExists "{urn:ietf:params:xml:ns:xmpp-session}optional") xpJid :: PU Text Jid diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index f47969a..7e69903 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -77,12 +77,19 @@ auth mechanisms resource con = runErrorT $ do _jid <- ErrorT $ xmppBind resource con ErrorT $ flip withStream' con $ do s <- get - case establishSession $ streamConfiguration s of + + case sendStreamElement s of False -> return $ Right Nothing True -> do - _ <-liftIO $ startSession con + _ <- liftIO $ startSession con return $ Right Nothing f -> return f + where + sendStreamElement s = + and [ -- Check that the stream feature is set and not optional + streamFeaturesSession (streamFeatures s) == Just False + ] + -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 631fa0b..740f1e3 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -727,6 +727,9 @@ data StreamFeatures = StreamFeatures -- versioning and @Just True@ when the server sends the non-standard -- "optional" element (observed with prosody). , streamFeaturesPreApproval :: !Bool -- ^ Does the server support pre-approval + , streamFeaturesSession :: !(Maybe Bool) + -- ^ Does this server allow the stream elelemt? (See + -- https://tools.ietf.org/html/draft-cridland-xmpp-session-01) , streamFeaturesOther :: ![Element] -- TODO: All feature elements instead? } deriving (Eq, Show) @@ -737,6 +740,7 @@ instance Monoid StreamFeatures where , streamFeaturesMechanisms = [] , streamFeaturesRosterVer = Nothing , streamFeaturesPreApproval = False + , streamFeaturesSession = Nothing , streamFeaturesOther = [] } mappend sf1 sf2 = @@ -747,6 +751,7 @@ instance Monoid StreamFeatures where , streamFeaturesPreApproval = streamFeaturesPreApproval sf1 || streamFeaturesPreApproval sf2 + , streamFeaturesSession = mplusOn streamFeaturesSession , streamFeaturesOther = mplusOn streamFeaturesOther } @@ -1245,8 +1250,6 @@ data StreamConfiguration = -- | Whether or not to perform the legacy -- session bind as defined in the (outdated) -- RFC 3921 specification - , establishSession :: Bool - -- | How the client should behave in regards to TLS. , tlsBehaviour :: TlsBehaviour -- | Settings to be used for TLS negotitation , tlsParams :: ClientParams @@ -1271,13 +1274,11 @@ xmppDefaultParams = (defaultParamsClient "" BS.empty) } } - instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing , connectionDetails = UseRealm , resolvConf = defaultResolvConf - , establishSession = True , tlsBehaviour = PreferTls , tlsParams = xmppDefaultParams }