Send session element depending on stream features

Fixes #94

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

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 =
+    liftIO . atomically $ putTMVar eh $
-                                                 onConnectionClosed config sess }
+        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

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

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)
+    (\(tls, sasl, ver, preAppr, session, rest)
-       -> StreamFeatures tls (mbl sasl) ver preAppr rest)
+       -> StreamFeatures tls (mbl sasl) ver preAppr session rest )
-    (\(StreamFeatures tls sasl ver preAppr rest)
+    (\(StreamFeatures tls sasl ver preAppr session rest)
-     -> (tls, lmb sasl, ver, preAppr, 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

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

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
                               }