set upper bound of conduit

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

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.
 --

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

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

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