diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -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 diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -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. diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -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 diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -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 "" diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs --- a/source/Network/Xmpp/IM/Roster/Types.hs +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -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 diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -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}) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -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", "") diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -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 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -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 diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -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 diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -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 diff --git a/tests/Tests/Parsers.hs b/tests/Tests/Parsers.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Parsers.hs @@ -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 diff --git a/tests/Tests/Picklers.hs b/tests/Tests/Picklers.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Picklers.hs @@ -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 = []})}