fix roster pushes not being handled

Fix the order of stanza handlers
Allow roster pushes with a from address that is the bare JID of the
client to be handled

source/Network/Xmpp/Concurrent.hs

@@ -170,7 +170,9 @@ newSession stream config realm mbSasl = runErrorT $ do
     peers <- liftIO . newTVarIO $ Peers Map.empty
     rew <- lift $ newTVarIO 60
     let out = writeStanza writeSem
-    let rosterH = if (enableRoster config) then [handleRoster ros out]
+    boundJid <- liftIO $ withStream' (gets streamJid) stream
+    let rosterH = if (enableRoster config)
+                  then [handleRoster boundJid ros out]
                   else []
     let presenceH = if (enablePresenceTracking config)
                     then [handlePresence peers out]
@@ -178,11 +180,10 @@ newSession stream config realm mbSasl = runErrorT $ do
     (sStanza, ps) <- initPlugins out $ plugins config
     let stanzaHandler = runHandlers $ List.concat
                         [ inHandler <$> ps
-                        , [ toChan stanzaChan sStanza
+                        , [ toChan stanzaChan sStanza]
-                          , handleIQ iqHands sStanza
-                          ]
                         , presenceH
                         , rosterH
+                        , [ handleIQ iqHands sStanza]
                         ]
     (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler
                                                         eh stream

source/Network/Xmpp/IM/Roster.hs

@@ -98,15 +98,24 @@ initRoster session = do
                           "Server did not return a roster: "
         Just roster -> atomically $ writeTVar (rosterRef session) roster
 
-handleRoster :: TVar Roster -> StanzaHandler
+handleRoster :: Maybe Jid -> TVar Roster -> StanzaHandler
-handleRoster ref out sta _ = case sta of
+handleRoster mbBoundJid ref out sta _ = do
+    case sta of
         IQRequestS (iqr@IQRequest{iqRequestPayload =
                                        iqb@Element{elementName = en}})
             | nameNamespace en == Just "jabber:iq:roster" -> do
-            case iqRequestFrom iqr of
+                let doHandle = case (iqRequestFrom iqr, mbBoundJid) of
-                Just _from -> return [(sta, [])] -- Don't handle roster pushes
+                        -- We don't need to check our own JID when the IQ
-                                                 -- from unauthorized sources
+                        -- request was sent without a from address
-                Nothing -> case unpickleElem xpQuery iqb of
+                        (Nothing, _) -> True
+                        -- We don't have a Jid bound, so we can't verify that
+                        -- the from address matches our bare jid
+                        (Just _fr, Nothing) -> False
+                        -- Check that the from address matches our bare jid
+                        (Just fr, Just boundJid) | fr == toBare boundJid -> True
+                                                 | otherwise -> False
+                if doHandle
+                    then case unpickleElem xpQuery iqb of
                         Right Query{ queryVer = v
                                    , queryItems = [update]
                                    } -> do
@@ -117,6 +126,8 @@ handleRoster ref out sta _ = case sta of
                             errorM "Pontarius.Xmpp" "Invalid roster query"
                             _ <- out $ badRequest iqr
                             return []
+                    -- Don't handle roster pushes from unauthorized sources
+                    else return [(sta, [])]
         _ -> return [(sta, [])]
   where
     handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) ->