From c9f511ebfe6418d18437958566286893805a0529 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 9 Nov 2013 18:15:25 +0100 Subject: [PATCH] more work on lenses rename stanza classes add traversable for payload change sid lens to point to Maybe Text export pluginsL --- source/Network/Xmpp.hs | 9 +- source/Network/Xmpp/Lens.hs | 179 +++++++++++++++++++----------------- 2 files changed, 100 insertions(+), 88 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index aa362db..921d6b9 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -176,11 +176,9 @@ module Network.Xmpp -- 'modify' and 'set') -- ** Stanzas - , HasStanzaAttrs(..) - , HasStanzaID(..) - , sid' + , IsStanza(..) + , IsErrorStanza(..) , HasStanzaPayload(..) - , HasStanzaError(..) , messageTypeL , presenceTypeL , iqRequestTypeL @@ -201,7 +199,8 @@ module Network.Xmpp , streamConfigurationL , onConnectionClosedL , sessionStanzaIDsL - , ensableRoster + , ensableRosterL + , pluginsL -- * Threads , dupSession -- * Miscellaneous diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index b37219b..46522df 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -10,6 +10,7 @@ -- use out of them. module Network.Xmpp.Lens ( Lens + , Traversal -- * Accessors -- | Reimplementation of the basic lens functions so you don't have to -- bring in all of lens library in to use the lenses @@ -18,11 +19,9 @@ module Network.Xmpp.Lens , set -- * Lenses -- ** Stanzas - , HasStanzaAttrs(..) - , HasStanzaID(..) - , sid' + , IsStanza(..) , HasStanzaPayload(..) - , HasStanzaError(..) + , IsErrorStanza(..) , messageTypeL , presenceTypeL , iqRequestTypeL @@ -43,11 +42,12 @@ module Network.Xmpp.Lens , streamConfigurationL , onConnectionClosedL , sessionStanzaIDsL - , ensableRoster + , ensableRosterL + , pluginsL ) where -import Control.Applicative((<$>), Const(..)) +import Control.Applicative import Data.Functor.Identity(Identity(..)) import qualified Data.Text as Text import Data.Text(Text) @@ -60,147 +60,159 @@ import Network.Xmpp.Concurrent.Types -- | Van-Laarhoven lenses. type Lens a b = Functor f => (b -> f b) -> a -> f a -class HasStanzaAttrs s where +type Traversal a b = Applicative f => (b -> f b) -> a -> f a + +class IsStanza s where -- | From-attribute of the stanza from :: Lens s (Maybe Jid) -- | To-attribute of the stanza to :: Lens s (Maybe Jid) -- | Langtag of the stanza lang :: Lens s (Maybe LangTag) + -- | Stanza ID. Setting this to /Nothing/ for IQ* stanzas will set the id to + -- the empty Text. + sid :: Lens s (Maybe Text) + -- | Traversal over the payload elements. + payloadT :: Traversal s Element +traverseList :: Traversal [a] a +traverseList _inj [] = pure [] +traverseList inj (x:xs) = (:) <$> inj x <*> traverseList inj xs -instance HasStanzaAttrs Message where +instance IsStanza Message where from inj m@(Message{messageFrom=f}) = (\f' -> m{messageFrom = f'}) <$> inj f to inj m@(Message{messageTo=t}) = (\t' -> m{messageTo = t'}) <$> inj t lang inj m@(Message{messageLangTag=t}) = (\t' -> m{messageLangTag = t'}) <$> inj t + sid inj m@(Message{messageID = i}) = + ((\i' -> m{messageID = i'}) <$> inj i) + payloadT inj m@(Message{messagePayload=pl}) = + (\pl' -> m{messagePayload=pl'}) <$> traverseList inj pl -instance HasStanzaAttrs MessageError where +instance IsStanza MessageError where from inj m@(MessageError{messageErrorFrom=f}) = (\f' -> m{messageErrorFrom = f'}) <$> inj f to inj m@(MessageError{messageErrorTo=t}) = (\t' -> m{messageErrorTo = t'}) <$> inj t lang inj m@(MessageError{messageErrorLangTag=t}) = (\t' -> m{messageErrorLangTag = t'}) <$> inj t + sid inj m@(MessageError{messageErrorID = i}) = + ((\i' -> m{messageErrorID = i'}) <$> inj i) + payloadT inj m@(MessageError{messageErrorPayload=pl}) = + (\pl' -> m{messageErrorPayload=pl'}) <$> traverseList inj pl -instance HasStanzaAttrs Presence where +instance IsStanza Presence where from inj m@(Presence{presenceFrom=f}) = (\f' -> m{presenceFrom = f'}) <$> inj f to inj m@(Presence{presenceTo=t}) = (\t' -> m{presenceTo = t'}) <$> inj t lang inj m@(Presence{presenceLangTag=t}) = (\t' -> m{presenceLangTag = t'}) <$> inj t + sid inj m@(Presence{presenceID = i}) = + ((\i' -> m{presenceID = i'}) <$> inj i) + payloadT inj m@(Presence{presencePayload=pl}) = + (\pl' -> m{presencePayload=pl'}) <$> traverseList inj pl -instance HasStanzaAttrs PresenceError where +instance IsStanza PresenceError where from inj m@(PresenceError{presenceErrorFrom=f}) = (\f' -> m{presenceErrorFrom = f'}) <$> inj f to inj m@(PresenceError{presenceErrorTo=t}) = (\t' -> m{presenceErrorTo = t'}) <$> inj t lang inj m@(PresenceError{presenceErrorLangTag=t}) = (\t' -> m{presenceErrorLangTag = t'}) <$> inj t + sid inj m@(PresenceError{presenceErrorID = i}) = + ((\i' -> m{presenceErrorID = i'}) <$> inj i) + payloadT inj m@(PresenceError{presenceErrorPayload=pl}) = + (\pl' -> m{presenceErrorPayload=pl'}) <$> traverseList inj pl -instance HasStanzaAttrs IQRequest where +instance IsStanza IQRequest where from inj m@(IQRequest{iqRequestFrom=f}) = (\f' -> m{iqRequestFrom = f'}) <$> inj f to inj m@(IQRequest{iqRequestTo=t}) = (\t' -> m{iqRequestTo = t'}) <$> inj t lang inj m@(IQRequest{iqRequestLangTag=t}) = (\t' -> m{iqRequestLangTag = t'}) <$> inj t + sid inj m@(IQRequest{iqRequestID = i}) = + ((\i' -> m{iqRequestID = i'}) <$> maybeNonempty inj i) + payloadT inj m@(IQRequest{iqRequestPayload=pl}) = + (\pl' -> m{iqRequestPayload=pl'}) <$> inj pl -instance HasStanzaAttrs IQResult where +instance IsStanza IQResult where from inj m@(IQResult{iqResultFrom=f}) = (\f' -> m{iqResultFrom = f'}) <$> inj f to inj m@(IQResult{iqResultTo=t}) = (\t' -> m{iqResultTo = t'}) <$> inj t lang inj m@(IQResult{iqResultLangTag=t}) = (\t' -> m{iqResultLangTag = t'}) <$> inj t + sid inj m@(IQResult{iqResultID = i}) = + ((\i' -> m{iqResultID = i'}) <$> maybeNonempty inj i) + payloadT inj m@(IQResult{iqResultPayload=pl}) = + (\pl' -> m{iqResultPayload=pl'}) <$> maybe (pure Nothing) + (fmap Just . inj) pl -instance HasStanzaAttrs IQError where +instance IsStanza IQError where from inj m@(IQError{iqErrorFrom=f}) = (\f' -> m{iqErrorFrom = f'}) <$> inj f to inj m@(IQError{iqErrorTo=t}) = (\t' -> m{iqErrorTo = t'}) <$> inj t lang inj m@(IQError{iqErrorLangTag=t}) = (\t' -> m{iqErrorLangTag = t'}) <$> inj t - -lift :: (forall s. HasStanzaAttrs s => Lens s a) -> Lens Stanza a -lift f inj (IQRequestS s) = IQRequestS <$> f inj s -lift f inj (IQResultS s) = IQResultS <$> f inj s -lift f inj (IQErrorS s) = IQErrorS <$> f inj s -lift f inj (MessageS s) = MessageS <$> f inj s -lift f inj (MessageErrorS s) = MessageErrorS <$> f inj s -lift f inj (PresenceS s) = PresenceS <$> f inj s -lift f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s - -instance HasStanzaAttrs Stanza where - from = lift from - to = lift to - lang = lift lang - -class HasStanzaID s i | s -> i where - sid :: Lens s i - -instance HasStanzaID IQRequest Text where - sid inj m@(IQRequest {iqRequestID = i}) = (\i' -> m{iqRequestID = i'}) <$> - inj i - -instance HasStanzaID IQResult Text where - sid inj m@(IQResult {iqResultID = i}) = (\i' -> m{iqResultID = i'}) <$> - inj i - -instance HasStanzaID IQError Text where - sid inj m@(IQError {iqErrorID = i}) = (\i' -> m{iqErrorID = i'}) <$> - inj i -instance HasStanzaID Message (Maybe Text) where - sid inj m@(Message {messageID = i}) = (\i' -> m{messageID = i'}) <$> - inj i - -instance HasStanzaID MessageError (Maybe Text) where - sid inj m@(MessageError {messageErrorID = i}) = - (\i' -> m{messageErrorID = i'}) <$> inj i - -instance HasStanzaID Presence (Maybe Text) where - sid inj m@(Presence {presenceID = i}) = (\i' -> m{presenceID = i'}) <$> - inj i - -instance HasStanzaID PresenceError (Maybe Text) where - sid inj m@(PresenceError {presenceErrorID = i}) = - (\i' -> m{presenceErrorID = i'}) <$> inj i - --- | Access to the ID of a stanza. Setting the stanza ID of any non-IQ* stanza --- to the empty string will instead set it to Nothing -sid' :: Lens Stanza Text -sid' inj (IQRequestS s) = IQRequestS <$> sid inj s -sid' inj (IQResultS s) = IQResultS <$> sid inj s -sid' inj (IQErrorS s) = IQErrorS <$> sid inj s -sid' inj (MessageS s) = MessageS <$> (sid . maybeNonempty) inj s -sid' inj (MessageErrorS s) = MessageErrorS <$> (sid . maybeNonempty) inj s -sid' inj (PresenceS s) = PresenceS <$> (sid . maybeNonempty) inj s -sid' inj (PresenceErrorS s) = PresenceErrorS <$> (sid . maybeNonempty) inj s - -maybeNonempty :: Lens (Maybe Text) Text -maybeNonempty inj Nothing = (\x -> if Text.null x then Nothing else Just x) - <$> inj Text.empty -maybeNonempty inj (Just x) = (\y -> if Text.null y then Nothing else Just y) - <$> inj x - -class HasStanzaError s where + sid inj m@(IQError{iqErrorID = i}) = + ((\i' -> m{iqErrorID = i'}) <$> maybeNonempty inj i) + payloadT inj m@(IQError{iqErrorPayload=pl}) = + (\pl' -> m{iqErrorPayload=pl'}) <$> maybe (pure Nothing) + (fmap Just . inj) pl + +liftLens :: (forall s. IsStanza s => Lens s a) -> Lens Stanza a +liftLens f inj (IQRequestS s) = IQRequestS <$> f inj s +liftLens f inj (IQResultS s) = IQResultS <$> f inj s +liftLens f inj (IQErrorS s) = IQErrorS <$> f inj s +liftLens f inj (MessageS s) = MessageS <$> f inj s +liftLens f inj (MessageErrorS s) = MessageErrorS <$> f inj s +liftLens f inj (PresenceS s) = PresenceS <$> f inj s +liftLens f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s + +liftTraversal :: (forall s. IsStanza s => Traversal s a) -> Traversal Stanza a +liftTraversal f inj (IQRequestS s) = IQRequestS <$> f inj s +liftTraversal f inj (IQResultS s) = IQResultS <$> f inj s +liftTraversal f inj (IQErrorS s) = IQErrorS <$> f inj s +liftTraversal f inj (MessageS s) = MessageS <$> f inj s +liftTraversal f inj (MessageErrorS s) = MessageErrorS <$> f inj s +liftTraversal f inj (PresenceS s) = PresenceS <$> f inj s +liftTraversal f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s + +instance IsStanza Stanza where + from = liftLens from + to = liftLens to + lang = liftLens lang + sid = liftLens sid + payloadT = liftTraversal payloadT + +maybeNonempty :: Lens Text (Maybe Text) +maybeNonempty inj x = (maybe Text.empty id) + <$> inj (if Text.null x then Nothing else Just x) + + +class IsErrorStanza s where -- | Error element of the stanza stanzaError :: Lens s StanzaError -instance HasStanzaError IQError where +instance IsErrorStanza IQError where stanzaError inj m@IQError{iqErrorStanzaError = i} = (\i' -> m{iqErrorStanzaError = i'}) <$> inj i -instance HasStanzaError MessageError where +instance IsErrorStanza MessageError where stanzaError inj m@MessageError{messageErrorStanzaError = i} = (\i' -> m{messageErrorStanzaError = i'}) <$> inj i -instance HasStanzaError PresenceError where +instance IsErrorStanza PresenceError where stanzaError inj m@PresenceError{presenceErrorStanzaError = i} = (\i' -> m{presenceErrorStanzaError = i'}) <$> inj i class HasStanzaPayload s p | s -> p where - -- | Payload element(s) of the stanza + -- | Payload element(s) of the stanza. Since the amount of elements possible + -- in a stanza vary by type, this lens can't be used with a general + -- 'Stanza'. There is, however, a more general Traversable that works with + -- all stanzas (including 'Stanza'): 'payloadT' payload :: Lens s p instance HasStanzaPayload IQRequest Element where @@ -310,10 +322,11 @@ sessionStanzaIDsL :: Lens SessionConfiguration (IO (IO Text)) sessionStanzaIDsL inj sc@SessionConfiguration{sessionStanzaIDs = x} = (\x' -> sc{sessionStanzaIDs = x'}) <$> inj x -ensableRoster :: Lens SessionConfiguration Bool -ensableRoster inj sc@SessionConfiguration{enableRoster = x} +ensableRosterL :: Lens SessionConfiguration Bool +ensableRosterL inj sc@SessionConfiguration{enableRoster = x} = (\x' -> sc{enableRoster = x'}) <$> inj x +pluginsL :: Lens SessionConfiguration [Plugin] pluginsL inj sc@SessionConfiguration{plugins = x} = (\x' -> sc{plugins = x'}) <$> inj x