From 92746237a9b8c90f4cbccd833656c29e8a07857d Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Mon, 10 Jun 2013 13:16:54 +0200
Subject: [PATCH] check for roster versioning stream feature and disable roster
 versioning unless present

---
 source/Network/Xmpp/Concurrent/Basic.hs |  6 ++++++
 source/Network/Xmpp/IM/Roster.hs        | 18 +++++++++++++-----
 source/Network/Xmpp/Marshal.hs          |  7 ++++---
 source/Network/Xmpp/Stream.hs           |  4 ++--
 source/Network/Xmpp/Types.hs            |  1 +
 5 files changed, 26 insertions(+), 10 deletions(-)

diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs
index 99623f9..b5d24d2 100644
--- a/source/Network/Xmpp/Concurrent/Basic.hs
+++ b/source/Network/Xmpp/Concurrent/Basic.hs
@@ -30,3 +30,9 @@ getJid :: Session -> IO (Maybe Jid)
 getJid Session{streamRef = st} = do
     s <- atomically $ readTMVar st
     withStream' (gets streamJid) s
+
+-- | Return the JID assigned to us by the server
+getFeatures :: Session -> IO StreamFeatures
+getFeatures Session{streamRef = st} = do
+    s <- atomically $ readTMVar st
+    withStream' (gets streamFeatures) s
diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs
index de62bb0..2f0dacf 100644
--- a/source/Network/Xmpp/IM/Roster.hs
+++ b/source/Network/Xmpp/IM/Roster.hs
@@ -4,6 +4,7 @@
 
 module Network.Xmpp.IM.Roster where
 
+import           Control.Applicative ((<$>))
 import           Control.Concurrent.STM
 import           Control.Monad
 import           Data.List (nub)
@@ -14,11 +15,12 @@ import           Data.XML.Pickle
 import           Data.XML.Types
 import           System.Log.Logger
 
+import           Network.Xmpp.Concurrent.Basic
+import           Network.Xmpp.Concurrent.IQ
+import           Network.Xmpp.Concurrent.Types
 import           Network.Xmpp.IM.Roster.Types
 import           Network.Xmpp.Marshal
-import           Network.Xmpp.Concurrent.Types
 import           Network.Xmpp.Types
-import           Network.Xmpp.Concurrent.IQ
 
 -- | Push a roster item to the server. The values for approved and ask are
 -- ignored and all values for subsciption except "remove" are ignored
@@ -107,9 +109,15 @@ handleRoster ref outC sta = case sta of
         IQResultS $ IQResult iqid Nothing from lang Nothing
 
 retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster)
-retrieveRoster oldRoster sess = do
+retrieveRoster mbOldRoster sess = do
+    useVersioning <- rosterVer <$> getFeatures sess
+    let version = if useVersioning
+                then case mbOldRoster of
+                      Nothing -> Just ""
+                      Just oldRoster -> ver oldRoster
+                else Nothing
     res <- sendIQ' Nothing Get Nothing
-        (pickleElem xpQuery (Query (ver =<< oldRoster) []))
+        (pickleElem xpQuery (Query version []))
         sess
     case res of
         IQResponseResult (IQResult{iqResultPayload = Just ros})
@@ -119,7 +127,7 @@ retrieveRoster oldRoster sess = do
                 return Nothing
             Right ros' -> return . Just $ toRoster ros'
         IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do
-            return oldRoster
+            return mbOldRoster
                 -- sever indicated that no roster updates are necessary
         IQResponseTimeout -> do
             errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out"
diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs
index ce68966..1a08d5f 100644
--- a/source/Network/Xmpp/Marshal.hs
+++ b/source/Network/Xmpp/Marshal.hs
@@ -250,17 +250,18 @@ xpStream = xpElemAttrs
 -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
 xpStreamFeatures :: PU [Node] StreamFeatures
 xpStreamFeatures = ("xpStreamFeatures","") <?> xpWrap
-    (\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest)
-    (\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest))
+    (\(tls, sasl, ver, rest) -> StreamFeatures tls (mbl sasl) ver rest)
+    (\(StreamFeatures tls sasl ver rest) -> (tls, lmb sasl, ver, rest))
     (xpElemNodes
          (Name
              "features"
              (Just "http://etherx.jabber.org/streams")
              (Just "stream")
          )
-         (xpTriple
+         (xp4Tuple
               (xpOption pickleTlsFeature)
               (xpOption pickleSaslFeature)
+              (xpElemExists "{urn:xmpp:features:rosterver}ver")
               (xpAll xpElemVerbatim)
          )
     )
diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs
index c80a8d9..089514f 100644
--- a/source/Network/Xmpp/Stream.hs
+++ b/source/Network/Xmpp/Stream.hs
@@ -488,7 +488,7 @@ xmppNoStream = StreamState {
       streamConnectionState = Closed
     , streamHandle = zeroHandle
     , streamEventSource = zeroSource
-    , streamFeatures = StreamFeatures Nothing [] []
+    , streamFeatures = StreamFeatures Nothing [] False []
     , streamAddress = Nothing
     , streamFrom = Nothing
     , streamId = Nothing
@@ -522,7 +522,7 @@ createStream realm config = do
                   { streamConnectionState = Plain
                   , streamHandle = hand
                   , streamEventSource = eSource
-                  , streamFeatures = StreamFeatures Nothing [] []
+                  , streamFeatures = StreamFeatures Nothing [] False []
                   , streamAddress = Just $ Text.pack realm
                   , streamFrom = Nothing
                   , streamId = Nothing
diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs
index e87212e..67d2343 100644
--- a/source/Network/Xmpp/Types.hs
+++ b/source/Network/Xmpp/Types.hs
@@ -823,6 +823,7 @@ langTagParser = do
 data StreamFeatures = StreamFeatures
     { streamTls            :: !(Maybe Bool)
     , streamSaslMechanisms :: ![Text.Text]
+    , rosterVer            :: !Bool
     , streamOtherFeatures  :: ![Element] -- TODO: All feature elements instead?
     } deriving Show