check for roster versioning stream feature and disable roster versioning unless present

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

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"

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

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

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