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,19 +170,20 @@ 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]
-                                           else []
+    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]
                     else []
     (sStanza, ps) <- initPlugins out $ plugins config
     let stanzaHandler = runHandlers $ List.concat
                         [ inHandler <$> ps
-                        , [ toChan stanzaChan sStanza
-                          , handleIQ iqHands sStanza
-                          ]
+                        , [ toChan stanzaChan sStanza]
                         , presenceH
                         , rosterH
+                        , [ handleIQ iqHands sStanza]
                         ]
     (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler
                                                         eh stream

source/Network/Xmpp/IM/Roster.hs

@@ -98,26 +98,37 @@ initRoster session = do
                           "Server did not return a roster: "
         Just roster -> atomically $ writeTVar (rosterRef session) roster
 
-handleRoster :: TVar Roster -> StanzaHandler
-handleRoster ref out sta _ = case sta of
-    IQRequestS (iqr@IQRequest{iqRequestPayload =
-                                   iqb@Element{elementName = en}})
-        | nameNamespace en == Just "jabber:iq:roster" -> do
-            case iqRequestFrom iqr of
-                Just _from -> return [(sta, [])] -- Don't handle roster pushes
-                                                 -- from unauthorized sources
-                Nothing -> case unpickleElem xpQuery iqb of
-                    Right Query{ queryVer = v
-                               , queryItems = [update]
-                               } -> do
-                        handleUpdate v update
-                        _ <- out $ result iqr
-                        return []
-                    _ -> do
-                        errorM "Pontarius.Xmpp" "Invalid roster query"
-                        _ <- out $ badRequest iqr
-                        return []
-    _ -> return [(sta, [])]
+handleRoster :: Maybe Jid -> TVar Roster -> StanzaHandler
+handleRoster mbBoundJid ref out sta _ = do
+    case sta of
+        IQRequestS (iqr@IQRequest{iqRequestPayload =
+                                       iqb@Element{elementName = en}})
+            | nameNamespace en == Just "jabber:iq:roster" -> do
+                let doHandle = case (iqRequestFrom iqr, mbBoundJid) of
+                        -- We don't need to check our own JID when the IQ
+                        -- request was sent without a from address
+                        (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
+                            handleUpdate v update
+                            _ <- out $ result iqr
+                            return []
+                        _ -> do
+                            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) ->
         Roster (v' `mplus` v) $ case qiSubscription update of