diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 6fade93..09a1d9e 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -172,7 +172,9 @@ newSession stream config realm mbSasl = runErrorT $ do let out = writeStanza writeSem boundJid <- liftIO $ withStream' (gets streamJid) stream let rosterH = if (enableRoster config) - then [handleRoster boundJid ros out] + then [handleRoster boundJid ros + (fromMaybe (\_ -> return ()) $ onRosterPush config) + out] else [] let presenceH = if (enablePresenceTracking config) then [handlePresence (onPresenceChange config) peers out] diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index ca5fa64..bcacf62 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -85,6 +85,9 @@ data SessionConfiguration = SessionConfiguration -- | Enable roster handling according to rfc 6121. See 'getRoster' to -- acquire the current roster , enableRoster :: Bool + -- | Callback called on a roster Push. The callback is called after the + -- roster is updated + , onRosterPush :: Maybe (QueryItem -> IO ()) -- | Track incomming presence stancas. , enablePresenceTracking :: Bool -- | Callback that is invoked when the presence status of a peer changes, @@ -112,6 +115,7 @@ instance Default SessionConfiguration where return . Text.pack . show $ curId , plugins = [] , enableRoster = True + , onRosterPush = Nothing , enablePresenceTracking = True , onPresenceChange = Nothing , keepAlive = Just 30 diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 15a8afc..7f54b96 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -98,8 +98,11 @@ initRoster session = do "Server did not return a roster: " Just roster -> atomically $ writeTVar (rosterRef session) roster -handleRoster :: Maybe Jid -> TVar Roster -> StanzaHandler -handleRoster mbBoundJid ref out sta _ = do +handleRoster :: Maybe Jid + -> TVar Roster + -> (QueryItem -> IO ()) + -> StanzaHandler +handleRoster mbBoundJid ref onUpdate out sta _ = do case sta of IQRequestS (iqr@IQRequest{iqRequestPayload = iqb@Element{elementName = en}}) @@ -120,6 +123,7 @@ handleRoster mbBoundJid ref out sta _ = do , queryItems = [update] } -> do handleUpdate v update + onUpdate update _ <- out $ result iqr return [] _ -> do