update roster callbacks

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

pontarius-xmpp.cabal

@@ -120,11 +120,11 @@ Library
 Test-Suite tests
   Type: exitcode-stdio-1.0
   main-is: Main.hs
-  Build-Depends: base
+  Build-Depends: Cabal
-               , 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

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

source/Network/Xmpp/IM.hs

@@ -21,6 +21,7 @@ module Network.Xmpp.IM
   -- * Roster
   , Roster(..)
   , Item(..)
+  , RosterUpdate(..)
   , getRoster
   , getRosterSTM
   , rosterAdd

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) ->
+    handleUpdate v' update =
-        Roster (v' `mplus` v) $ case qiSubscription update of
+        case qiSubscription update of
-            Just Remove -> Map.delete (qiJid update) is
+         Just Remove -> do
-            _ -> Map.insert (qiJid update) (toItem update) is
+             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) []

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

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
 -------------------