From 8f9d54dee3b14b8ceacc8b5c72c0ac8d6ab8b8c6 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 4 Sep 2014 18:40:06 +0200 Subject: [PATCH] set upper bound of conduit --- pontarius-xmpp.cabal | 4 ++- source/Network/Xmpp/Concurrent.hs | 17 +++++++++--- source/Network/Xmpp/Concurrent/Presence.hs | 8 ++++-- source/Network/Xmpp/Concurrent/Types.hs | 5 ++++ source/Network/Xmpp/IM/PresenceTracker.hs | 32 ++-------------------- 5 files changed, 29 insertions(+), 37 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index b2c0b84..900e242 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -40,7 +40,7 @@ Library , base >4 && <5 , base64-bytestring >=0.1.0.0 , binary >=0.4.1 - , conduit >=1.0.1 + , conduit >=1.0.1 && < 1.2 , containers >=0.4.0.0 , crypto-api >=0.9 , crypto-random >=0.0.5 @@ -96,6 +96,8 @@ Library , Network.Xmpp.IM.PresenceTracker , Network.Xmpp.IM.Roster , Network.Xmpp.IM.Roster.Types + , Network.Xmpp.IM.PresenceTracker + , Network.Xmpp.IM.PresenceTracker.Types , Network.Xmpp.Marshal , Network.Xmpp.Sasl , Network.Xmpp.Sasl.Common diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 3841ad7..3c4152e 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -40,6 +40,8 @@ import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Concurrent.Types import Network.Xmpp.IM.Roster import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.IM.PresenceTracker +import Network.Xmpp.IM.PresenceTracker.Types import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types import Network.Xmpp.Stream @@ -165,30 +167,37 @@ newSession stream config realm mbSasl = runErrorT $ do iqHands <- lift $ newTVarIO (Map.empty, Map.empty) eh <- lift $ newEmptyTMVarIO ros <- liftIO . newTVarIO $ Roster Nothing Map.empty + peers <- liftIO . newTVarIO $ Peers Map.empty rew <- lift $ newTVarIO 60 let out = writeStanza writeSem let rosterH = if (enableRoster config) then [handleRoster ros out] else [] + let presenceH = if (enablePresenceTracking config) + then [handlePresence peers out] + else [] (sStanza, ps) <- initPlugins out $ plugins config let stanzaHandler = runHandlers $ List.concat [ inHandler <$> ps , [ toChan stanzaChan sStanza , handleIQ iqHands sStanza ] + , presenceH , rosterH ] - (kill, streamState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream + (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler + eh stream idGen <- liftIO $ sessionStanzaIDs config let sess = Session { stanzaCh = stanzaChan , iqHandlers = iqHands , writeSemaphore = writeSem , readerThread = reader , idGenerator = idGen - , streamRef = streamState + , streamRef = sState , eventHandlers = eh , stopThreads = kill , conf = config , rosterRef = ros + , presenceRef = peers , sendStanza' = sStanza , sRealm = realm , sSaslCredentials = mbSasl @@ -196,9 +205,11 @@ newSession stream config realm mbSasl = runErrorT $ do } liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler = onConnectionClosed config sess } + -- Pass the new session to the plugins so they can "tie the knot" liftIO . forM_ ps $ \p -> onSessionUp p sess return sess where + -- Pass the stanza out action to each plugin initPlugins out' = go out' [] where go out ps' [] = return (out, ps') @@ -269,8 +280,6 @@ simpleAuth uname pwd = Just (\cstate -> else [] , Nothing) - - -- | Reconnect immediately with the stored settings. Returns @Just@ the error -- when the reconnect attempt fails and Nothing when no failure was encountered. -- diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs index 054d728..c5c28ed 100644 --- a/source/Network/Xmpp/Concurrent/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -3,10 +3,12 @@ module Network.Xmpp.Concurrent.Presence where import Control.Applicative ((<$>)) import Control.Concurrent.STM -import Network.Xmpp.Types -import Network.Xmpp.Concurrent.Types +import Lens.Family2 hiding (to) +import Lens.Family2.Stock import Network.Xmpp.Concurrent.Basic +import Network.Xmpp.Concurrent.Types import Network.Xmpp.Lens +import Network.Xmpp.Types -- | Read a presence stanza from the inbound stanza channel, discards any other -- stanzas. Returns the presence stanza with annotations. @@ -47,5 +49,5 @@ sendPresence p session = sendStanza (PresenceS checkedP) session -- potential instant messaging and presence contact, the value of the 'to' -- attribute MUST be a bare JID rather than a full JID checkedP = case presenceType p of - Subscribe -> modify to (fmap toBare) p + Subscribe -> p & to . _Just %~ toBare _ -> p diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 10b72d1..0684711 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -17,6 +17,7 @@ import Data.Typeable import Data.XML.Types (Element) import Network import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.IM.PresenceTracker.Types import Network.Xmpp.Sasl.Types import Network.Xmpp.Types @@ -84,6 +85,8 @@ data SessionConfiguration = SessionConfiguration -- | Enable roster handling according to rfc 6121. See 'getRoster' to -- acquire the current roster , enableRoster :: Bool + -- | Track incomming presence stancas. + , enablePresenceTracking :: Bool } instance Default SessionConfiguration where @@ -97,6 +100,7 @@ instance Default SessionConfiguration where return . Text.pack . show $ curId , plugins = [] , enableRoster = True + , enablePresenceTracking = True } -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is @@ -130,6 +134,7 @@ data Session = Session , eventHandlers :: TMVar EventHandlers , stopThreads :: IO () , rosterRef :: TVar Roster + , presenceRef :: TVar Peers , conf :: SessionConfiguration , sendStanza' :: Stanza -> IO (Either XmppFailure ()) , sRealm :: HostName diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs index fd82595..0663e28 100644 --- a/source/Network/Xmpp/IM/PresenceTracker.hs +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -3,30 +3,19 @@ module Network.Xmpp.IM.PresenceTracker where import Control.Applicative import Control.Concurrent.STM -import Control.Monad (guard) import Data.Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe -import Data.Traversable import Lens.Family2 import Lens.Family2.Stock import Network.Xmpp.Concurrent.Types import Network.Xmpp.IM.Presence -import Network.Xmpp.IM.Roster import Network.Xmpp.Lens hiding (Lens, Traversal) import Network.Xmpp.Types import Prelude hiding (mapM) --- Map from bare JIDs to a map of full JIDs to show maybe status. --- --- Invariants: --- * The outer map should not have entries for bare JIDs that have no --- available resource, i.e. the inner map should never be empty --- --- * The inner map keys' local and domain part coincide with the outer keys' -newtype Peers = Peers { unPeers :: Map Jid (Map Jid (Maybe IMPresence))} - deriving (Show) +import Network.Xmpp.IM.PresenceTracker.Types _peers :: Iso Peers (Map Jid (Map Jid (Maybe IMPresence))) _peers = mkIso unPeers Peers @@ -69,26 +58,11 @@ peerStatusL j = _peers . at (toBare j) . maybeMap . at j . _PeerStatus peerMapPeerAvailable :: Jid -> Peers -> Bool peerMapPeerAvailable j = not . nullOf (peerStatusL j . _PeerAvailable) -statusTracker :: (Stanza -> IO (Either XmppFailure ())) - -> IO (Plugin', TVar Peers) -statusTracker out = do - sessRef <- newTVarIO Nothing - peerMap <- newTVarIO (Peers Map.empty) - - return (Plugin' { inHandler = handleIn sessRef peerMap - , outHandler = out - , onSessionUp = atomically . writeTVar sessRef . Just - }, peerMap) - where - handleIn sessRef peers st _ = do - mbRoster <- atomically (mapM getRoster' =<< readTVar sessRef) +handlePresence :: TVar Peers -> StanzaHandler +handlePresence peers _ st _ = do let mbPr = do pr <- st ^? _Presence -- Only act on presence stanzas fr <- pr ^? from . _Just . _isFull -- Only act on full JIDs - roster <- mbRoster - -- Check that the from address is in our roster. This means that - -- deactivating the roster effectively turns off this plugin - guard $ Map.member (toBare fr) (roster ^. itemsL) return (pr, fr) forM_ mbPr $ \(pr, fr) -> case presenceType pr of