diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 59ca13f..3170382 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -68,6 +68,8 @@ Library , xml-conduit >=1.1.0.7 , xml-picklers >=0.3.3 , x509-system >=1.4 + , profunctors >= 4 + , lens-family If impl(ghc ==7.0.1) { Build-Depends: bytestring >=0.9.1.9 && <=0.9.2.1 diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 14d4b6f..42adfeb 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -4,11 +4,11 @@ module Network.Xmpp.IM.Presence where -import Data.Default -import Data.Text (Text) -import Data.XML.Pickle -import Data.XML.Types -import Network.Xmpp.Types +import Data.Default +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp.Types data ShowStatus = StatusAway | StatusChat @@ -53,6 +53,7 @@ xpIMPresence = xpUnliftElems . xp3Tuple (xpOption $ xpElemNodes "{jabber:client}show" (xpContent xpShow)) + -- TODO: Multiple status elements with different lang tags (xpOption $ xpElemNodes "{jabber:client}status" (xpContent xpText)) (xpOption $ xpElemNodes "{jabber:client}priority" diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 62f70a9..1292f25 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -78,9 +78,13 @@ rosterRemove j sess = do let el = pickleElem xpQuery (Query Nothing [fromItem item]) sendIQA' timeout Nothing Set Nothing el [] session +-- | Retrieve the current Roster state (STM version) +getRoster' :: Session -> STM Roster +getRoster' session = readTVar (rosterRef session) + -- | Retrieve the current Roster state getRoster :: Session -> IO Roster -getRoster session = atomically $ readTVar (rosterRef session) +getRoster session = atomically $ getRoster' session -- | Get the initial roster or refresh the roster. You don't need to call this -- on your own. diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index 9b0dcd8..9f61ddf 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -5,20 +5,32 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} --- | Van Laarhoven lenses for XMPP types. The lenses are designed to work with --- the lens library. This module also provides a few simple accessors ('view', --- 'modify', 'set' and 'getAll') so you don't need to pull in the --- lens library to get some use out of them. +-- | (More than just) Van Laarhoven lenses for XMPP types. The accessors in here +-- are designed to work with an optics library like lens or lens-family. This +-- module also provides a few simple functions ('view', 'modify', 'set' and +-- 'getAll') so you don't need to pull in another library to get some use out +-- of them. -- --- The name of the lenses corresponds to the field name of the data types with +-- * The name of the lenses corresponds to the field name of the data types with -- an upper-case L appended. For documentation of the fields refer to the documentation of the data types (linked in the section header) +-- +-- * Same goes for Traversals, except they are suffixed with a \'T\' +-- +-- * Prism generally start with an underscore +-- +-- /NB/ you do not need to import this module to get access to the optics +-- defined herein. They are also exported from Network.Xmpp. You only need to +-- import this module if you want to use the complementary accessor functions +-- without using an optics library like lens or lens-family module Network.Xmpp.Lens ( Lens , Traversal + , Prism + , Iso -- * Accessors -- | Reimplementation of the basic lens functions so you don't have to - -- bring in all of lens library in to use the lenses + -- bring in a lens library to use the optics -- ** Lenses , view @@ -26,9 +38,27 @@ module Network.Xmpp.Lens , set -- * Traversals , getAll + -- * Prisms + + -- ** Construction + , prism' + , mkLens + -- * Lenses + -- ** JID + , _JidText + , _isFull + , _isBare + -- ** Stanzas + , _IQRequest + , _IQResult + , _IQError + , _Message + , _MessageError + , _Presence + , _PresenceError , IsStanza(..) , HasStanzaPayload(..) , IsErrorStanza(..) @@ -109,25 +139,39 @@ module Network.Xmpp.Lens where import Control.Applicative -import Data.Functor.Identity(Identity(..)) +import qualified Data.ByteString as BS +import Data.Functor.Identity (Identity(..)) import qualified Data.Map as Map +import Data.Profunctor +import Data.Text (Text) import qualified Data.Text as Text -import Data.Text(Text) -import Data.XML.Types(Element) -import Network.DNS(ResolvConf) +import Data.XML.Types (Element) +import Network.DNS (ResolvConf) import Network.TLS as TLS import Network.Xmpp.Concurrent.Types import Network.Xmpp.IM.Message import Network.Xmpp.IM.Presence import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Types -import qualified Data.ByteString as BS -- | Van-Laarhoven lenses. type Lens a b = Functor f => (b -> f b) -> a -> f a type Traversal a b = 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) + +type Iso a b = forall p f. (Profunctor p, Functor f) => p a (f a) -> p b (f b) + +prism' :: (b -> s) -> (s -> Maybe b) -> Prism s b +prism' bs sma = dimap (\s -> maybe (Left s) Right (sma s)) + (either pure (fmap bs)) . right' + +mkLens :: (a -> b) -> (b -> a -> a) -> Lens a b +mkLens get set = \inj x -> fmap (flip set x) (inj $ get x) + +mkIso :: (a -> b) -> (b -> a) -> Iso a b +mkIso to from = dimap from (fmap to) -- Accessors --------------- @@ -154,10 +198,18 @@ instance Applicative (Collect a) where getAll :: Traversal a b -> a -> [b] getAll t = getCollection . t (Collect . pure) - -- Xmpp Lenses -------------------- +_JidText :: Prism Text Jid +_JidText = prism' jidToText jidFromText + +_isFull :: Prism Jid Jid +_isFull = prism' id (\j -> if isFull j then Just j else Nothing) + +_isBare :: Prism Jid Jid +_isBare = prism' toBare (\j -> if isBare j then Just j else Nothing) + class IsStanza s where -- | From-attribute of the stanza from :: Lens s (Maybe Jid) @@ -288,6 +340,48 @@ maybeNonempty inj x = (maybe Text.empty id) <$> inj (if Text.null x then Nothing else Just x) +_IQRequest :: Prism Stanza IQRequest +_IQRequest = prism' IQRequestS fromIQRequestS + where + fromIQRequestS (IQRequestS s) = Just s + fromIQRequestS _ = Nothing + +_IQResult :: Prism Stanza IQResult +_IQResult = prism' IQResultS fromIQResultS + where + fromIQResultS (IQResultS s) = Just s + fromIQResultS _ = Nothing + +_IQError :: Prism Stanza IQError +_IQError = prism' IQErrorS fromIQErrorS + where + fromIQErrorS (IQErrorS s) = Just s + fromIQErrorS _ = Nothing + +_Message :: Prism Stanza Message +_Message = prism' MessageS fromMessageS + where + fromMessageS (MessageS s) = Just s + fromMessageS _ = Nothing + +_MessageError :: Prism Stanza MessageError +_MessageError = prism' MessageErrorS fromMessageErrorS + where + fromMessageErrorS (MessageErrorS s) = Just s + fromMessageErrorS _ = Nothing + +_Presence :: Prism Stanza Presence +_Presence = prism' PresenceS fromPresenceS + where + fromPresenceS (PresenceS s) = Just s + fromPresenceS _ = Nothing + +_PresenceError :: Prism Stanza PresenceError +_PresenceError = prism' PresenceErrorS fromPresenceErrorS + where + fromPresenceErrorS (PresenceErrorS s) = Just s + fromPresenceErrorS _ = Nothing + class IsErrorStanza s where -- | Error element of the stanza stanzaError :: Lens s StanzaError diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 31d8174..06de8ef 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -22,6 +22,7 @@ module Network.Xmpp.Types , IQResponse(..) , IQResult(..) , LangTag (..) + , langTagQ , langTagFromText , langTagToText , parseLangTag @@ -38,6 +39,8 @@ module Network.Xmpp.Types , SaslFailure(..) , StreamFeatures(..) , Stanza(..) + , messageS + , presenceS , StanzaError(..) , StanzaErrorCondition(..) , StanzaErrorType(..) @@ -45,6 +48,7 @@ module Network.Xmpp.Types , XmppTlsError(..) , StreamErrorCondition(..) , Version(..) + , versionFromText , StreamHandle(..) , Stream(..) , StreamState(..) @@ -53,6 +57,7 @@ module Network.Xmpp.Types , ConnectionDetails(..) , StreamConfiguration(..) , xmppDefaultParams + , xmppDefaultParamsStrong , Jid(..) #if WITH_TEMPLATE_HASKELL , jidQ @@ -704,10 +709,10 @@ data StreamFeatures = StreamFeatures -- | Signals the state of the stream connection. data ConnectionState - = Closed -- ^ No stream has been established + = Closed -- ^ Stream has not been established yet | Plain -- ^ Stream established, but not secured via TLS | Secured -- ^ Stream established and secured via TLS - | Finished -- ^ Stream is closed + | Finished -- ^ Stream was closed deriving (Show, Eq, Typeable) -- | Defines operations for sending, receiving, flushing, and closing on a