From 0b0dcc5fe0e369610d99e7074217c285d0c73d97 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 11 Jan 2016 17:01:55 +0100 Subject: [PATCH] update roster callbacks --- ChangeLog.md | 3 ++- pontarius-xmpp.cabal | 5 +++-- source/Network/Xmpp/Concurrent/Types.hs | 2 +- source/Network/Xmpp/IM.hs | 1 + source/Network/Xmpp/IM/Roster.hs | 20 ++++++++++++++------ source/Network/Xmpp/IM/Roster/Types.hs | 4 ++++ source/Network/Xmpp/Lens.hs | 19 +++++++++++++++++-- 7 files changed, 42 insertions(+), 12 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index c1a42bd..414b242 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,5 @@ -# 0.5.1 to 0.5.2 +# 0.5.1 to 0.6.0 +* Changed roster update callback to take RosterUpdate type * Added onrosterPushL lens # 0.5.0 to 0.5.1 diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index ddf142d..96a49ea 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -120,11 +120,11 @@ Library Test-Suite tests Type: exitcode-stdio-1.0 main-is: Main.hs - Build-Depends: base - , Cabal + Build-Depends: Cabal , QuickCheck , async , async + , base , conduit , containers , data-default @@ -133,6 +133,7 @@ Test-Suite tests , hspec , hspec-expectations , lens + , mtl , network , pontarius-xmpp , quickcheck-instances diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index bce659d..e90c4c5 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -70,7 +70,7 @@ type Plugin = (XmppElement -> IO (Either XmppFailure ())) -- ^ pass stanza to -- next plugin -> ErrorT XmppFailure IO Plugin' -type RosterPushCallback = (QueryItem -> IO ()) +type RosterPushCallback = RosterUpdate -> IO () -- | Configuration for the @Session@ object. data SessionConfiguration = SessionConfiguration diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index bc0cf07..b803dc7 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -21,6 +21,7 @@ module Network.Xmpp.IM -- * Roster , Roster(..) , Item(..) + , RosterUpdate(..) , getRoster , getRosterSTM , rosterAdd diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index cd36f99..9f67e9d 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -100,7 +100,7 @@ initRoster session = do handleRoster :: Maybe Jid -> TVar Roster - -> (QueryItem -> IO ()) + -> RosterPushCallback -> StanzaHandler handleRoster mbBoundJid ref onUpdate out sta _ = do case sta of @@ -123,7 +123,6 @@ handleRoster mbBoundJid ref onUpdate out sta _ = do , queryItems = [update] } -> do handleUpdate v update - onUpdate update _ <- out . XmppStanza $ result iqr return [] _ -> do @@ -134,10 +133,19 @@ handleRoster mbBoundJid ref onUpdate out sta _ = do else return [(sta, [])] _ -> return [(sta, [])] where - handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) -> - Roster (v' `mplus` v) $ case qiSubscription update of - Just Remove -> Map.delete (qiJid update) is - _ -> Map.insert (qiJid update) (toItem update) is + handleUpdate v' update = + case qiSubscription update of + Just Remove -> do + let j = qiJid update + onUpdate $ RosterUpdateRemove j + updateRoster (Map.delete j) + _ -> do + let i = (toItem update) + onUpdate $ RosterUpdateAdd i + updateRoster $ Map.insert (qiJid update) i + where + updateRoster f = atomically . modifyTVar ref $ + \(Roster v is) -> Roster (v' `mplus` v) (f is) badRequest (IQRequest iqid from _to lang _tp bd _attrs) = IQErrorS $ IQError iqid Nothing from lang errBR (Just bd) [] diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs index 7c03c98..d54173f 100644 --- a/source/Network/Xmpp/IM/Roster/Types.hs +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -35,6 +35,10 @@ data Item = Item { riApproved :: Bool , riGroups :: [Text] } deriving Show +data RosterUpdate = RosterUpdateRemove Jid + | RosterUpdateAdd Item -- ^ New or updated item + deriving Show + data QueryItem = QueryItem { qiApproved :: Maybe Bool , qiAsk :: Bool , qiJid :: Jid diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index d20183b..ef0d74a 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -597,8 +597,8 @@ verL inj r@Roster{ver = x} = (\x' -> r{ver = x'}) <$> inj x itemsL :: Lens Roster (Map.Map Jid Item) itemsL inj r@Roster{items = x} = (\x' -> r{items = x'}) <$> inj x --- Service Discovery Item ----------------------- +-- Item +------------------ riApprovedL :: Lens Item Bool riApprovedL inj i@Item{riApproved = x} = (\x' -> i{riApproved = x'}) <$> inj x @@ -619,6 +619,21 @@ riSubscriptionL inj i@Item{riSubscription = x} = riGroupsL :: Lens Item [Text] riGroupsL inj i@Item{riGroups = x} = (\x' -> i{riGroups = x'}) <$> inj x +-- Roster Update +------------------- + +_RosterUpdateRemove :: Prism RosterUpdate Jid +_RosterUpdateRemove = prism' RosterUpdateRemove fromRosterUpdateRemove + where + fromRosterUpdateRemove (RosterUpdateRemove jid) = Just jid + fromRosterUpdateRemove RosterUpdateAdd{} = Nothing + +_RosterUpdateAdd :: Prism RosterUpdate Item +_RosterUpdateAdd = prism' RosterUpdateAdd fromRosterUpdateAdd + where + fromRosterUpdateAdd RosterUpdateRemove{} = Nothing + fromRosterUpdateAdd (RosterUpdateAdd item) = Just item + -- QueryItem -------------------