rename stream feature fields and export lenses

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

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

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

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

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

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