From 7225f2cdbce59978d8589cc111fc523493462798 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 5 Nov 2013 15:37:05 +0100 Subject: [PATCH] more lenses --- source/Network/Xmpp.hs | 20 +++++++- source/Network/Xmpp/Lens.hs | 88 +++++++++++++++++++++++++++++++++++- source/Network/Xmpp/Types.hs | 18 ++++---- 3 files changed, 115 insertions(+), 11 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index f4947e1..815701a 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -172,13 +172,31 @@ module Network.Xmpp , StanzaErrorCondition(..) , SaslFailure(..) -- * Lenses - -- | import Network.Xmpp.Lens for basic lens functions ('view', + -- | You can import Network.Xmpp.Lens for basic lens functions ('view', -- 'modify' and 'set') + + -- ** Stanzas , HasStanzaAttrs(..) , HasStanzaID(..) , sid' , HasStanzaPayload(..) , HasStanzaError(..) + , messageTypeL + , presenceTypeL + , iqRequestTypeL + -- ** StanzaError + , stanzaErrorTypeL + , stanzaErrorConditionL + , stanzaErrorTextL + , stanzaErrorApplL + -- ** StreamConfiguration + , preferredLangL + , toJidL + , connectionDetailsL + , resolvConfL + , establishSessionL + , tlsBehaviourL + , tlsParamsL -- * Threads , dupSession -- * Miscellaneous diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index 4178e1f..91e8b38 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -5,7 +5,9 @@ {-# LANGUAGE FunctionalDependencies #-} -- | Van Laarhoven lenses for XMPP types. The lenses are designed to work with --- the lens library. +-- the lens library. This module also provides 3 simple accessors ('view', +-- 'modify', 'set') so you don't need to pull in the lens library to get some +-- use out of them. module Network.Xmpp.Lens ( Lens -- * Accessors @@ -15,11 +17,29 @@ module Network.Xmpp.Lens , modify , set -- * Lenses + -- ** Stanzas , HasStanzaAttrs(..) , HasStanzaID(..) , sid' , HasStanzaPayload(..) , HasStanzaError(..) + , messageTypeL + , presenceTypeL + , iqRequestTypeL + -- ** StanzaError + , stanzaErrorTypeL + , stanzaErrorConditionL + , stanzaErrorTextL + , stanzaErrorApplL + -- ** StreamConfiguration + , preferredLangL + , toJidL + , connectionDetailsL + , resolvConfL + , establishSessionL + , tlsBehaviourL + , tlsParamsL + ) where @@ -28,6 +48,8 @@ import Data.Functor.Identity(Identity(..)) import qualified Data.Text as Text import Data.Text(Text) import Data.XML.Types(Element) +import Network.DNS(ResolvConf) +import Network.TLS (TLSParams) import Network.Xmpp.Types -- | Van-Laarhoven lenses. @@ -204,6 +226,70 @@ instance HasStanzaPayload PresenceError [Element] where payload inj m@PresenceError{presenceErrorPayload = i} = (\i' -> m{presenceErrorPayload = i'}) <$> inj i +iqRequestTypeL :: Lens IQRequest IQRequestType +iqRequestTypeL inj p@IQRequest{iqRequestType = tp} = + (\tp' -> p{iqRequestType = tp'}) <$> inj tp + + +messageTypeL :: Lens Message MessageType +messageTypeL inj p@Message{messageType = tp} = + (\tp' -> p{messageType = tp'}) <$> inj tp + +presenceTypeL :: Lens Presence PresenceType +presenceTypeL inj p@Presence{presenceType = tp} = + (\tp' -> p{presenceType = tp'}) <$> inj tp + + +-- StanzaError +----------------------- + +stanzaErrorTypeL :: Lens StanzaError StanzaErrorType +stanzaErrorTypeL inj se@StanzaError{stanzaErrorType = x} = + (\x' -> se{stanzaErrorType = x'}) <$> inj x + +stanzaErrorConditionL :: Lens StanzaError StanzaErrorCondition +stanzaErrorConditionL inj se@StanzaError{stanzaErrorCondition = x} = + (\x' -> se{stanzaErrorCondition = x'}) <$> inj x + +stanzaErrorTextL :: Lens StanzaError (Maybe (Maybe LangTag, Text)) +stanzaErrorTextL inj se@StanzaError{stanzaErrorText = x} = + (\x' -> se{stanzaErrorText = x'}) <$> inj x + +stanzaErrorApplL :: Lens StanzaError (Maybe Element) +stanzaErrorApplL inj se@StanzaError{stanzaErrorApplicationSpecificCondition = x} = + (\x' -> se{stanzaErrorApplicationSpecificCondition = x'}) <$> inj x + + +-- StreamConfiguration +----------------------- + +preferredLangL :: Lens StreamConfiguration (Maybe LangTag) +preferredLangL inj sc@StreamConfiguration{preferredLang = x} + = (\x' -> sc{preferredLang = x'}) <$> inj x + +toJidL :: Lens StreamConfiguration (Maybe (Jid, Bool)) +toJidL inj sc@StreamConfiguration{toJid = x} + = (\x' -> sc{toJid = x'}) <$> inj x + +connectionDetailsL :: Lens StreamConfiguration ConnectionDetails +connectionDetailsL inj sc@StreamConfiguration{connectionDetails = x} + = (\x' -> sc{connectionDetails = x'}) <$> inj x + +resolvConfL :: Lens StreamConfiguration ResolvConf +resolvConfL inj sc@StreamConfiguration{resolvConf = x} + = (\x' -> sc{resolvConf = x'}) <$> inj x + +establishSessionL :: Lens StreamConfiguration Bool +establishSessionL inj sc@StreamConfiguration{establishSession = x} + = (\x' -> sc{establishSession = x'}) <$> inj x + +tlsBehaviourL :: Lens StreamConfiguration TlsBehaviour +tlsBehaviourL inj sc@StreamConfiguration{tlsBehaviour = x} + = (\x' -> sc{tlsBehaviour = x'}) <$> inj x + +tlsParamsL :: Lens StreamConfiguration TLSParams +tlsParamsL inj sc@StreamConfiguration{tlsParams = x} + = (\x' -> sc{tlsParams = x'}) <$> inj x -- | Read the value the lens is pointing to view :: Lens a b -> a -> b diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index da12cc6..cee529b 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -262,9 +262,9 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence -- wrapped in the @StanzaError@ type. -- TODO: Sender XML is (optional and is) not yet included. data StanzaError = StanzaError - { stanzaErrorType :: StanzaErrorType - , stanzaErrorCondition :: StanzaErrorCondition - , stanzaErrorText :: Maybe (Maybe LangTag, Text) + { stanzaErrorType :: StanzaErrorType + , stanzaErrorCondition :: StanzaErrorCondition + , stanzaErrorText :: Maybe (Maybe LangTag, Text) , stanzaErrorApplicationSpecificCondition :: Maybe Element } deriving (Eq, Show) @@ -896,7 +896,7 @@ domainpart = domainpart_ resourcepart :: Jid -> Maybe Text resourcepart = resourcepart_ --- Parses an JID string and returns its three parts. It performs no validation +-- Parses a JID string and returns its three parts. It performs no validation -- or transformations. jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) jidParts = do @@ -1023,12 +1023,12 @@ data StreamConfiguration = } instance Default StreamConfiguration where - def = StreamConfiguration { preferredLang = Nothing - , toJid = Nothing + def = StreamConfiguration { preferredLang = Nothing + , toJid = Nothing , connectionDetails = UseRealm - , resolvConf = defaultResolvConf - , establishSession = True - , tlsBehaviour = PreferTls + , resolvConf = defaultResolvConf + , establishSession = True + , tlsBehaviour = PreferTls , tlsParams = defaultParamsClient { pConnectVersion = TLS10 , pAllowedVersions = [TLS10, TLS11, TLS12] , pCiphers = ciphersuite_strong