pontarius-xmpp 0.5.1 → 0.5.2

raw patch · 11 files changed

+71/−25 lines, 11 filesdep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• pontarius-xmpp.cabal +4/−3
• source/Network/Xmpp/Concurrent.hs +1/−1
• source/Network/Xmpp/Concurrent/Types.hs +3/−1
• source/Network/Xmpp/IM.hs +1/−0
• source/Network/Xmpp/IM/Roster.hs +15/−6
• source/Network/Xmpp/IM/Roster/Types.hs +4/−0
• source/Network/Xmpp/Lens.hs +21/−2
• source/Network/Xmpp/Stream.hs +3/−0
• source/Network/Xmpp/Types.hs +14/−11
• tests/Tests/Stream.hs +1/−1

@@ -1,3 +1,7 @@+# 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 * Fixed input logger choking on long non-ascii messages 

@@ -1,5 +1,5 @@ Name:          pontarius-xmpp-Version:       0.5.1+Version:       0.5.2 Cabal-Version: >= 1.9.2 Build-Type:    Custom License:       BSD3@@ -120,11 +120,11 @@ 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 @@                , hspec                , hspec-expectations                , lens+               , mtl                , network                , pontarius-xmpp                , quickcheck-instances

@@ -188,7 +188,7 @@     boundJid <- liftIO $ withStream' (gets streamJid) stream     let rosterH = if (enableRoster config)                   then [handleRoster boundJid rosRef-                          (fromMaybe (\_ -> return ()) $ onRosterPush config)+                          (fromMaybe (\_ _ -> return ()) $ onRosterPush config)                           (out)]                   else []     let presenceH = if (enablePresenceTracking config)

@@ -70,6 +70,8 @@                                                           -- next plugin               -> ErrorT XmppFailure IO Plugin' +type RosterPushCallback = Roster -> RosterUpdate -> IO ()+ -- | Configuration for the @Session@ object. data SessionConfiguration = SessionConfiguration     { -- | Configuration for the @Stream@ object.@@ -90,7 +92,7 @@     , initialRoster              :: IO (Maybe Roster)       -- | Callback called on a roster Push. The callback is called after the       -- roster is updated-    , onRosterPush               :: Maybe (QueryItem -> IO ())+    , onRosterPush               :: Maybe RosterPushCallback       -- | Track incomming presence stancas.     , enablePresenceTracking     :: Bool       -- | Callback that is invoked when the presence status of a peer changes,

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

@@ -100,7 +100,7 @@  handleRoster :: Maybe Jid              -> TVar Roster-             -> (QueryItem -> IO ())+             -> RosterPushCallback              -> StanzaHandler handleRoster mbBoundJid ref onUpdate out sta _ = do     case sta of@@ -123,7 +123,6 @@                                    , queryItems = [update]                                    } -> do                             handleUpdate v update-                            onUpdate update                             _ <- out . XmppStanza $ result iqr                             return []                         _ -> do@@ -134,10 +133,20 @@                     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 = do+        oldRoster <- atomically $ readTVar ref+        case qiSubscription update of+         Just Remove -> do+             let j = qiJid update+             onUpdate oldRoster $ RosterUpdateRemove j+             updateRoster (Map.delete j)+         _ -> do+             let i = (toItem update)+             onUpdate oldRoster $ 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) []

@@ -35,6 +35,10 @@                  , 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

@@ -102,6 +102,7 @@        , onConnectionClosedL        , sessionStanzaIDsL        , ensableRosterL+       , onRosterPushL        , pluginsL        , onPresenceChangeL          -- ** IM@@ -552,6 +553,9 @@ ensableRosterL inj sc@SessionConfiguration{enableRoster = x}     = (\x' -> sc{enableRoster = x'}) <$> inj x +onRosterPushL :: Lens SessionConfiguration (Maybe RosterPushCallback)+onRosterPushL = mkLens onRosterPush (\orp x -> x{onRosterPush = orp})+ pluginsL :: Lens SessionConfiguration [Plugin] pluginsL inj sc@SessionConfiguration{plugins = x}     = (\x' -> sc{plugins = x'}) <$> inj x@@ -593,8 +597,8 @@ 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@@ -614,6 +618,21 @@  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

@@ -740,6 +740,9 @@               $ \resolver -> do         srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "."         case fixDnsResult srvResult of+            Just [] -> do+                debugM "Pontarius.Xmpp" "No SRV result returned."+                return Nothing             Just [(_, _, _, ".")] -> do                 debugM "Pontarius.Xmpp" $ "\".\" SRV result returned."                 return $ Just []

@@ -894,17 +894,20 @@     readsPrec _ s = do         -- Verifies that the first word is "parseJid", parses the second word and         -- the remainder, if any, and produces these two values or fails.-        let (s', r) = case lex s of-                          [] -> error "Expected `parseJid \"<jid>\"'"-                          [("parseJid", r')] -> case lex r' of-                                              [] -> error "Expected `parseJid \"<jid>\"'"-                                              [(s'', r'')] -> (s'', r'')-                                              _ -> error "Expected `parseJid \"<jid>\"'"-                          _ -> error "Expected `parseJid \"<jid>\"'"-        -- Read the JID string (removes the quotes), validate, and return.-        [(parseJid (read s' :: String), r)] -- May fail with "Prelude.read: no parse"-                                            -- or the `parseJid' error message (see below)+      case lex s of+        [("parseJid", r')] ->+          case lex r' of+            [(s', r'')] ->+              case (reads s') of+                ((jidTxt,_):_) ->+                  case jidFromText (Text.pack jidTxt) of+                       Nothing -> []+                       Just jid' -> [(jid', r'')]+                _ -> []+            _ -> []+        _ -> [] + #if WITH_TEMPLATE_HASKELL  instance TH.Lift Jid where@@ -1071,7 +1074,7 @@ -- >>> jidFromTexts (Just "foo") "bar" (Just "baz") == jidFromText "foo@bar/baz" -- True ----- prop> jidFromTexts (localpart j) (domainpart j) (resourcepart j) == Just j+-- prop> \j -> jidFromTexts (localpart j) (domainpart j) (resourcepart j) == Just j jidFromTexts :: Maybe Text -> Text -> Maybe Text -> Maybe Jid jidFromTexts l d r = do     localPart <- case l of

@@ -13,7 +13,7 @@ import           Test.Tasty.Hspec import           Test.Tasty.TH -import           Network.Xmpp.Stream+import           Network.Xmpp.Internal  junk = [ EventBeginDocument        , EventEndDocument