From c88c5c5ffa1cc8dfeab759e281ca176553dc392f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 10 Nov 2013 16:37:40 +0100 Subject: [PATCH] add lenses for instant messages --- source/Network/Xmpp.hs | 33 +--------- source/Network/Xmpp/IM/Message.hs | 2 +- source/Network/Xmpp/IM/Roster/Types.hs | 4 +- source/Network/Xmpp/Lens.hs | 86 +++++++++++++++++++++++++- 4 files changed, 90 insertions(+), 35 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 921d6b9..51265eb 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -171,38 +171,9 @@ module Network.Xmpp , StanzaErrorType(..) , StanzaErrorCondition(..) , SaslFailure(..) - -- * Lenses - -- | You can import Network.Xmpp.Lens for basic lens functions ('view', - -- 'modify' and 'set') - - -- ** Stanzas - , IsStanza(..) - , IsErrorStanza(..) - , HasStanzaPayload(..) - , messageTypeL - , presenceTypeL - , iqRequestTypeL - -- ** StanzaError - , stanzaErrorTypeL - , stanzaErrorConditionL - , stanzaErrorTextL - , stanzaErrorApplL - -- ** StreamConfiguration - , preferredLangL - , toJidL - , connectionDetailsL - , resolvConfL - , establishSessionL - , tlsBehaviourL - , tlsParamsL - -- ** SessionConfiguration - , streamConfigurationL - , onConnectionClosedL - , sessionStanzaIDsL - , ensableRosterL - , pluginsL -- * Threads , dupSession + module Network.Xmpp.Lens -- * Miscellaneous , LangTag , langTagFromText @@ -226,4 +197,4 @@ import Network.Xmpp.Sasl.Types import Network.Xmpp.Stanza import Network.Xmpp.Types import Network.Xmpp.Tls -import Network.Xmpp.Lens +import Network.Xmpp.Lens hiding (view, show, modify) diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index f29e163..439a5c5 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -47,7 +47,7 @@ getIM im = either (const Nothing) Just . unpickle xpIM $ messagePayload im sanitizeIM :: InstantMessage -> InstantMessage sanitizeIM im = im{imBody = nubBy ((==) `on` bodyLang) $ imBody im} --- | Append IM data to a message +-- | Append IM data to a message. Additional IM bodies with the same Langtag withIM :: Message -> InstantMessage -> Message withIM m im = m{ messagePayload = messagePayload m ++ pickleTree xpIM (sanitizeIM im) } diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs index 9be3280..6c63e82 100644 --- a/source/Network/Xmpp/IM/Roster/Types.hs +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -10,8 +10,8 @@ import Network.Xmpp.Types data Subscription = None | To | From | Both | Remove deriving (Eq, Read, Show) data Roster = Roster { ver :: Maybe Text - , items :: Map.Map Jid Item } deriving Show - + , items :: Map.Map Jid Item + } deriving Show -- | Roster Items data Item = Item { riApproved :: Bool diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index 46522df..12cc320 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -44,18 +44,38 @@ module Network.Xmpp.Lens , sessionStanzaIDsL , ensableRosterL , pluginsL + -- ** Roster + , verL + , itemsL + -- ** IM + , bodyLangL + , bodyContentL + , threadIdL + , threadParentL + , subjectLangL + , subjectContentL + , imThreadL + , imSubjectL + , imBodyL + -- IM Presence + , showStatusL + , statusL + , priorityL + ) where import Control.Applicative import Data.Functor.Identity(Identity(..)) +import qualified Data.Map as Map 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 import Network.Xmpp.Concurrent.Types +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.Types -- | Van-Laarhoven lenses. type Lens a b = Functor f => (b -> f b) -> a -> f a @@ -341,3 +361,67 @@ modify l f x = runIdentity $ l (fmap f . Identity) x -- | Replace the value the lens is pointing to set :: Lens a b -> b -> a -> a set l b x = modify l (const b) x + + +-- Roster +------------------ + +verL :: Lens Roster (Maybe Text) +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 + +-- IM +------------------- + + +bodyLangL :: Lens MessageBody (Maybe LangTag) +bodyLangL inj m@MessageBody{bodyLang = bl} = (\bl' -> m{bodyLang = bl'}) <$> inj bl + +bodyContentL :: Lens MessageBody Text +bodyContentL inj m@MessageBody{bodyContent = bc} = + (\bc' -> m{bodyContent = bc'}) <$> inj bc + +threadIdL :: Lens MessageThread Text +threadIdL inj m@MessageThread{threadID = bc} = + (\bc' -> m{threadID = bc'}) <$> inj bc + +threadParentL :: Lens MessageThread (Maybe Text) +threadParentL inj m@MessageThread{threadParent = bc} = + (\bc' -> m{threadParent = bc'}) <$> inj bc + +subjectLangL :: Lens MessageSubject (Maybe LangTag) +subjectLangL inj m@MessageSubject{subjectLang = bc} = + (\bc' -> m{subjectLang = bc'}) <$> inj bc + +subjectContentL :: Lens MessageSubject Text +subjectContentL inj m@MessageSubject{subjectContent = bc} = + (\bc' -> m{subjectContent = bc'}) <$> inj bc + +imThreadL :: Lens InstantMessage (Maybe MessageThread) +imThreadL inj m@InstantMessage{imThread = bc} = + (\bc' -> m{imThread = bc'}) <$> inj bc + +imSubjectL :: Lens InstantMessage [MessageSubject] +imSubjectL inj m@InstantMessage{imSubject = bc} = + (\bc' -> m{imSubject = bc'}) <$> inj bc + +imBodyL :: Lens InstantMessage [MessageBody] +imBodyL inj m@InstantMessage{imBody = bc} = + (\bc' -> m{imBody = bc'}) <$> inj bc + +-- IM Presence +------------------ + +showStatusL :: Lens IMPresence (Maybe ShowStatus) +showStatusL inj m@IMP{showStatus = bc} = + (\bc' -> m{showStatus = bc'}) <$> inj bc + +statusL :: Lens IMPresence (Maybe Text) +statusL inj m@IMP{status = bc} = + (\bc' -> m{status = bc'}) <$> inj bc + +priorityL :: Lens IMPresence (Maybe Int) +priorityL inj m@IMP{priority = bc} = + (\bc' -> m{priority = bc'}) <$> inj bc