From fbcf55df780bb28dead5475abf7196ca950b262d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 17 Sep 2015 17:18:40 +0200 Subject: [PATCH] rename stream feature fields and export lenses --- source/Network/Xmpp/IM/Roster.hs | 2 +- source/Network/Xmpp/Lens.hs | 36 +++++++++++++++++++++++++--- source/Network/Xmpp/Sasl.hs | 2 +- source/Network/Xmpp/Stream.hs | 4 ++-- source/Network/Xmpp/Tls.hs | 2 +- source/Network/Xmpp/Types.hs | 41 ++++++++++++++++++++++++-------- 6 files changed, 69 insertions(+), 18 deletions(-) diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 565c51b..15a8afc 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -143,7 +143,7 @@ handleRoster mbBoundJid ref out sta _ = do 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/Lens.hs b/source/Network/Xmpp/Lens.hs index b7339b8..be5bdcf 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -70,6 +70,14 @@ module Network.Xmpp.Lens , stanzaErrorConditionL , stanzaErrorTextL , stanzaErrorApplL + -- ** Stream + + -- ** Stream Features + , featureTlsL + , featureMechanismsL + , featureRosterVerL + , featurePreApprovalL + , featuresOtherL -- *** 'StreamConfiguration' , preferredLangL , toJidL @@ -159,10 +167,10 @@ import Network.Xmpp.Types -- | 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 @@ 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 --- Item +-- Service Discovery Item ---------------------- riApprovedL :: Lens Item Bool @@ -682,3 +690,25 @@ statusL inj m@IMP{status = bc} = 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/Sasl.hs b/source/Network/Xmpp/Sasl.hs index b373e70..f47969a 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -39,7 +39,7 @@ xmppSasl handlers stream = do 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 index 286243b..db461c9 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -497,7 +497,7 @@ xmppNoStream = StreamState { streamConnectionState = Closed , streamHandle = zeroHandle , streamEventSource = zeroSource - , streamFeatures = StreamFeatures Nothing [] Nothing [] + , streamFeatures = mempty , streamAddress = Nothing , streamFrom = Nothing , streamId = Nothing @@ -534,7 +534,7 @@ createStream realm config = do { 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 index 6e4bed9..1fbc18a 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -71,7 +71,7 @@ tls con = fmap join -- We can have Left values both from exceptions and the 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 index 0a61cf7..631fa0b 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -720,18 +720,39 @@ langTagParser = do 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). - , streamSubPreApproval :: !Bool -- ^ Does the server support pre-approval - , 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 = Closed -- ^ Stream has not been established yet