pontarius-xmpp 0.4.3 → 0.4.4

raw patch · 13 files changed

+244/−23 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• pontarius-xmpp.cabal +3/−1
• source/Network/Xmpp.hs +3/−0
• source/Network/Xmpp/Concurrent/Basic.hs +1/−1
• source/Network/Xmpp/IM/Roster.hs +1/−1
• source/Network/Xmpp/IM/Roster/Types.hs +14/−1
• source/Network/Xmpp/Lens.hs +33/−3
• source/Network/Xmpp/Marshal.hs +8/−3
• source/Network/Xmpp/Sasl.hs +1/−1
• source/Network/Xmpp/Stream.hs +2/−2
• source/Network/Xmpp/Tls.hs +1/−1
• source/Network/Xmpp/Types.hs +31/−9
• tests/Tests/Parsers.hs +57/−0
• tests/Tests/Picklers.hs +89/−0

@@ -1,5 +1,5 @@ Name:          pontarius-xmpp-Version:       0.4.3+Version:       0.4.4 Cabal-Version: >= 1.9.2 Build-Type:    Custom License:       BSD3@@ -154,6 +154,8 @@   Other-modules: Tests.Arbitrary                , Tests.Arbitrary.Xml                , Tests.Arbitrary.Xmpp+               , Tests.Parsers+               , Tests.Picklers   ghc-options: -Wall -O2 -fno-warn-orphans  Test-Suite doctest

@@ -59,6 +59,9 @@   , endSession   , waitForStream   , streamState+    -- ** Feature+  , StreamFeatures(..)+  , getFeatures     -- ** Authentication handlers     -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be     -- useful for interaction with older implementations.

@@ -56,7 +56,7 @@     s <- atomically $ readTMVar st     withStream' (gets streamJid) s --- | Return the JID assigned to us by the server+-- | Return the stream features the server announced getFeatures :: Session -> IO StreamFeatures getFeatures Session{streamRef = st} = do     s <- atomically $ readTMVar st

@@ -143,7 +143,7 @@  retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster) retrieveRoster mbOldRoster sess = do-    useVersioning <- isJust . rosterVer <$> getFeatures sess+    useVersioning <- isJust . streamFeaturesRosterVer <$> getFeatures sess     let version = if useVersioning                 then case mbOldRoster of                       Nothing -> Just ""

@@ -7,7 +7,20 @@  -- Note that `Remove' is not exported from IM.hs, as it will never be visible to -- the user anyway.-data Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show)+data Subscription = None -- ^ the user does not have a subscription to the+                         -- contact's presence information, and the contact does+                         -- not have a subscription to the user's presence+                         -- information+                  | To  -- ^ the user has a subscription to the contact's+                        -- presence information, but the contact does not have a+                        -- subscription to the user's presence information+                  | From -- ^ the contact has a subscription to the user's+                         -- presence information, but the user does not have a+                         -- subscription to the contact's presence information+                  | Both -- ^ both the user and the contact have subscriptions+                         -- to each other's presence information+                  | Remove+                  deriving (Eq, Read, Show)  data Roster = Roster { ver :: Maybe Text                      , items :: Map.Map Jid Item

@@ -70,6 +70,14 @@        , stanzaErrorConditionL        , stanzaErrorTextL        , stanzaErrorApplL+         -- ** Stream++         -- ** Stream Features+       , featureTlsL+       , featureMechanismsL+       , featureRosterVerL+       , featurePreApprovalL+       , featuresOtherL          -- *** 'StreamConfiguration'        , preferredLangL        , toJidL@@ -159,10 +167,10 @@  -- | Van-Laarhoven lenses. {-# DEPRECATED Lens "Use Lens' from lens-family or lens" #-}-type Lens a b = Functor f => (b -> f b) -> a -> f a+type Lens a b = forall f . Functor f => (b -> f b) -> a -> f a  {-# DEPRECATED Traversal "Use Traversal' from lens-family or lens" #-}-type Traversal a b = Applicative f => (b -> f b) -> a -> f a+type Traversal a b = forall f . Applicative f => (b -> f b) -> a -> f a  type Prism a b = forall p f. (Choice p, Applicative f) => p b (f b) -> p a (f a) @@ -577,7 +585,7 @@ itemsL :: Lens Roster (Map.Map Jid Item) itemsL inj r@Roster{items = x} = (\x' -> r{items = x'}) <$> inj x --- Item+-- Service Discovery Item ----------------------  riApprovedL :: Lens Item Bool@@ -682,3 +690,25 @@ priorityL :: Lens IMPresence (Maybe Int) priorityL inj m@IMP{priority = bc} =     (\bc' -> m{priority = bc'}) <$> inj bc++-- StreamFeatures+-------------------++featureTlsL :: Lens StreamFeatures (Maybe Bool)+featureTlsL = mkLens streamFeaturesTls (\x sf -> sf{streamFeaturesTls = x})++featureMechanismsL :: Lens StreamFeatures [Text]+featureMechanismsL =+    mkLens streamFeaturesMechanisms (\x sf -> sf{streamFeaturesMechanisms = x})++featureRosterVerL :: Lens StreamFeatures (Maybe Bool)+featureRosterVerL =+    mkLens streamFeaturesRosterVer (\x sf -> sf{streamFeaturesRosterVer = x})++featurePreApprovalL :: Lens StreamFeatures Bool+featurePreApprovalL =+    mkLens streamFeaturesPreApproval (\x sf -> sf{streamFeaturesPreApproval = x})++featuresOtherL :: Lens StreamFeatures [Element]+featuresOtherL =+    mkLens streamFeaturesOther (\x sf -> sf{streamFeaturesOther = x})

@@ -350,18 +350,21 @@ -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. xpStreamFeatures :: PU [Node] StreamFeatures xpStreamFeatures = ("xpStreamFeatures","") <?> xpWrap-    (\(tls, sasl, ver, rest) -> StreamFeatures tls (mbl sasl) ver rest)-    (\(StreamFeatures tls sasl ver rest) -> (tls, lmb sasl, ver, rest))+    (\(tls, sasl, ver, preAppr, rest)+       -> StreamFeatures tls (mbl sasl) ver preAppr rest)+    (\(StreamFeatures tls sasl ver preAppr rest)+     -> (tls, lmb sasl, ver, preAppr, rest))     (xpElemNodes          (Name              "features"              (Just "http://etherx.jabber.org/streams")              (Just "stream")          )-         (xp4Tuple+         (xp5Tuple               (xpOption pickleTlsFeature)               (xpOption pickleSaslFeature)               (xpOption pickleRosterVer)+              picklePreApproval               (xpAll xpElemVerbatim)          )     )@@ -377,6 +380,8 @@              "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))     pickleRosterVer = xpElemNodes "{urn:xmpp:features:rosterver}ver" $                            xpElemExists "{urn:xmpp:features:rosterver}optional"+    picklePreApproval = xpElemExists "{urn:xmpp:features:pre-approval}sub"+  xpJid :: PU Text Jid xpJid = ("xpJid", "") <?>

@@ -39,7 +39,7 @@     flip withStream stream $ do         -- Chooses the first mechanism that is acceptable by both the client and the         -- server.-        mechanisms <- gets $ streamSaslMechanisms . streamFeatures+        mechanisms <- gets $ streamFeaturesMechanisms . streamFeatures         case (filter (\(name, _) -> name `elem` mechanisms)) handlers of             [] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms             (_name, handler):_ -> do

@@ -497,7 +497,7 @@       streamConnectionState = Closed     , streamHandle = zeroHandle     , streamEventSource = zeroSource-    , streamFeatures = StreamFeatures Nothing [] Nothing []+    , streamFeatures = mempty     , streamAddress = Nothing     , streamFrom = Nothing     , streamId = Nothing@@ -534,7 +534,7 @@                   { streamConnectionState = Plain                   , streamHandle = hand                   , streamEventSource = eSource-                  , streamFeatures = StreamFeatures Nothing [] Nothing []+                  , streamFeatures = mempty                   , streamAddress = Just $ Text.pack realm                   , streamFrom = Nothing                   , streamId = Nothing

@@ -71,7 +71,7 @@             liftIO $ errorM "Pontarius.Xmpp.Tls" "The stream is already secured."             throwError TlsStreamSecured     features <- lift $ gets streamFeatures-    case (tlsBehaviour conf, streamTls features) of+    case (tlsBehaviour conf, streamFeaturesTls features) of         (RequireTls  , Just _   ) -> startTls         (RequireTls  , Nothing  ) -> throwError TlsNoServerSupport         (PreferTls   , Just _   ) -> startTls

@@ -720,16 +720,38 @@     tagChars = ['a'..'z'] ++ ['A'..'Z']  data StreamFeatures = StreamFeatures-    { streamTls            :: !(Maybe Bool)-    , streamSaslMechanisms :: ![Text.Text]-    , rosterVer            :: !(Maybe Bool) -- ^ @Nothing@ for no roster-                                            -- versioning, @Just False@ for-                                            -- roster versioning and @Just True@-                                            -- when the server sends the-                                            -- non-standard "optional" element-                                            -- (observed with prosody).-    , streamOtherFeatures  :: ![Element] -- TODO: All feature elements instead?+    { streamFeaturesTls         :: !(Maybe Bool)+    , streamFeaturesMechanisms  :: ![Text.Text]+    , streamFeaturesRosterVer   :: !(Maybe Bool)+      -- ^ @Nothing@ for no roster versioning, @Just False@ for roster+      -- versioning and @Just True@ when the server sends the non-standard+      -- "optional" element (observed with prosody).+    , streamFeaturesPreApproval :: !Bool -- ^ Does the server support pre-approval+    , streamFeaturesOther       :: ![Element]+      -- TODO: All feature elements instead?     } deriving (Eq, Show)++instance Monoid StreamFeatures where+    mempty = StreamFeatures+               { streamFeaturesTls         = Nothing+               , streamFeaturesMechanisms  = []+               , streamFeaturesRosterVer   = Nothing+               , streamFeaturesPreApproval = False+               , streamFeaturesOther       = []+               }+    mappend sf1 sf2 =+        StreamFeatures+               { streamFeaturesTls = mplusOn streamFeaturesTls+               , streamFeaturesMechanisms  = mplusOn streamFeaturesMechanisms+               , streamFeaturesRosterVer   = mplusOn streamFeaturesRosterVer+               , streamFeaturesPreApproval =+                 streamFeaturesPreApproval sf1+                 || streamFeaturesPreApproval sf2+               , streamFeaturesOther       = mplusOn streamFeaturesOther++               }+      where+        mplusOn f = f sf1 `mplus` f sf2  -- | Signals the state of the stream connection. data ConnectionState

@@ -0,0 +1,57 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Tests.Parsers where++import Control.Applicative ((<$>))+import Network.Xmpp.Internal+import Test.Hspec+import Test.Tasty.QuickCheck+import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.HUnit++import Tests.Arbitrary ()++case_JidFromText :: Assertion+case_JidFromText = hspec . describe "jidFromText" $ do+    it "parses a full JID" $ jidFromText "foo@bar.com/quux"+                             `shouldBe` Just (Jid (Just "foo")+                                          "bar.com"+                                          (Just "quux"))+    it "parses a bare JID" $ jidFromText "foo@bar.com"+                             `shouldBe` Just (Jid (Just "foo")+                                          "bar.com"+                                          Nothing)+    it "parses a domain" $ jidFromText "bar.com"+                             `shouldBe` Just (Jid Nothing+                                          "bar.com"+                                          Nothing)+    it "parses domain with resource" $ jidFromText "bar.com/quux"+                             `shouldBe` Just (Jid Nothing+                                          "bar.com"+                                          (Just "quux"))+    it "rejects multiple '@'" $  shouldReject "foo@bar@baz"+    it "rejects multiple '/'" $  shouldReject "foo/bar/baz"+    it "rejects multiple '/' after '@'" $ shouldReject  "quux@foo/bar/baz"+    it "rejects '@' after '/'" $ shouldReject "foo/bar@baz"+    it "rejects empty local part" $ shouldReject "@bar/baz"+    it "rejects empty resource part" $ shouldReject "foo@bar/"+    it "rejects empty domain part" $ shouldReject "foo@/baz"+  where shouldReject jid = jidFromText jid `shouldBe` Nothing++prop_jidFromText_rightInverse :: Jid -> Bool+prop_jidFromText_rightInverse j = let jidText = jidToText j in+        (jidToText <$> jidFromText jidText) == Just jidText++prop_jidFromText_leftInverse :: Jid -> Bool+prop_jidFromText_leftInverse jid = (jidFromText $ jidToText jid) == Just jid+++case_LangTagParser :: Assertion+case_LangTagParser = hspec . describe "langTagFromText" $+                    it "has some properties" $ pendingWith "Check requirements"++parserTests :: TestTree+parserTests = $testGroupGenerator

@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Tests.Picklers where++import Tests.Arbitrary ()+import Data.XML.Pickle+import Network.Xmpp.Internal+import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.QuickCheck+import Data.Text (Text)++import Data.XML.Types++-- | Test Pickler self-inverse: Check that unpickling after pickling gives the+-- original value+tpsi :: Eq a => PU t a -> a -> Bool+tpsi p = \x -> case unpickle p (pickle p x) of+    Left _ -> False+    Right x' -> x == x'++testPickler :: PU t a -> a -> IO ()+testPickler p x = case unpickle p (pickle p x) of+    Left e -> putStrLn $ ppUnpickleError e+    Right _ -> putStrLn "OK."++prop_xpStreamStanza_invertibe :: Either StreamErrorInfo Stanza -> Bool+prop_xpStreamStanza_invertibe         = tpsi xpStreamStanza+prop_xpStanza_invertibe :: Stanza -> Bool+prop_xpStanza_invertibe               = tpsi xpStanza+prop_xpMessage_invertibe :: Message -> Bool+prop_xpMessage_invertibe              = tpsi xpMessage+prop_xpPresence_invertibe             = tpsi xpPresence+prop_xpPresence_invertibe :: Presence -> Bool+prop_xpIQRequest_invertibe            = tpsi xpIQRequest+prop_xpIQRequest_invertibe :: IQRequest -> Bool+prop_xpIQResult_invertibe             = tpsi xpIQResult+prop_xpIQResult_invertibe :: IQResult -> Bool+prop_xpErrorCondition_invertibe       = tpsi xpStanzaErrorCondition+prop_xpErrorCondition_invertibe :: StanzaErrorCondition -> Bool+prop_xpStanzaError_invertibe          = tpsi xpStanzaError+prop_xpStanzaError_invertibe :: StanzaError -> Bool+prop_xpMessageError_invertibe         = tpsi xpMessageError+prop_xpMessageError_invertibe :: MessageError -> Bool+prop_xpPresenceError_invertibe        = tpsi xpPresenceError+prop_xpPresenceError_invertibe :: PresenceError -> Bool+prop_xpIQError_invertibe              = tpsi xpIQError+prop_xpIQError_invertibe :: IQError -> Bool+prop_xpStreamError_invertibe          = tpsi xpStreamError+prop_xpStreamError_invertibe :: StreamErrorInfo -> Bool+prop_xpLangTag_invertibe              = tpsi xpLangTag+prop_xpLangTag_invertibe :: Maybe LangTag -> Bool+prop_xpLang_invertibe                 = tpsi xpLang+prop_xpLang_invertibe :: LangTag -> Bool+prop_xpStream_invertibe               = tpsi xpStream+prop_xpStream_invertibe :: ( Text+                           , Maybe Jid+                           , Maybe Jid+                           , Maybe Text+                           , Maybe LangTag )+                           -> Bool+prop_xpJid_invertibe                  = tpsi xpJid+prop_xpJid_invertibe :: Jid -> Bool+prop_xpIQRequestType_invertibe        = tpsi xpIQRequestType+prop_xpIQRequestType_invertibe :: IQRequestType -> Bool+prop_xpMessageType_invertibe          = tpsi xpMessageType+prop_xpMessageType_invertibe :: MessageType -> Bool+prop_xpPresenceType_invertibe         = tpsi xpPresenceType+prop_xpPresenceType_invertibe :: PresenceType -> Bool+prop_xpStanzaErrorType_invertibe      = tpsi xpStanzaErrorType+prop_xpStanzaErrorType_invertibe :: StanzaErrorType -> Bool+prop_xpStanzaErrorCondition_invertibe = tpsi xpStanzaErrorCondition+prop_xpStanzaErrorCondition_invertibe :: StanzaErrorCondition -> Bool+prop_xpStreamErrorCondition_invertibe = tpsi xpStreamErrorCondition+prop_xpStreamErrorCondition_invertibe :: StreamErrorCondition -> Bool+-- prop_xpStreamFeatures_invertibe = testPicklerInvertible xpStreamFeatures++picklerTests :: TestTree+picklerTests = $testGroupGenerator++bad = StreamErrorInfo { errorCondition = StreamInvalidFrom+                      , errorText = Just (Nothing,"")+                      , errorXml = Just (+                          Element { elementName =+                                         Name { nameLocalName = "\65044"+                                              , nameNamespace = Just "\14139"+                                              , namePrefix = Just "\651"}+                                  , elementAttributes = []+                                  , elementNodes = []})}