TraversableT based sendProbesAndSolicitations code

1 files changed, 43 insertions, 10 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 606bd05e..0f2b7c89 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -30,10 +30,10 @@ import qualified Data.ByteString.Lazy.Char8 as L
 import qualified ConfigFiles
 import Data.Maybe (listToMaybe,mapMaybe)
 
+import TraversableT
 import UTmp (ProcessID,users)
 import LocalPeerCred
 import XMPPServer
--- import Server
 
 unsplitJID (n,h,r) = jid
  where
@@ -50,8 +50,7 @@ splitJID bjid =
         splitAll c bjid = take 1 xs0 ++ map (Text.drop 1) (drop 1 xs0)
             where xs0 = Text.groupBy (\x y-> y/=c) bjid
         server = head ys
-        name
-            = case xs of
+        name = case xs of
                 (n:s:_) -> Just n
                 (s:_)   -> Nothing
         rsrc = case ys of
@@ -78,13 +77,22 @@ data ClientState = ClientState
     }
 
 
-data PresenceContainer = PresenceContainer
+data LocalPresence = LocalPresence
     { networkClients :: Map ConnectionKey ClientState
     -- TODO: loginClients
     }
 
+data RemotePresence = RemotePresence
+    { resources :: Map Text ()
+    -- , localSubscribers :: Map Text ()
+    -- ^ subset of clientsByUser who should be
+    -- notified about this presence.
+    }
+
+
+
 pcSingletonNetworkClient key client =
-    PresenceContainer
+    LocalPresence
     { networkClients = Map.singleton key client
     } 
 
@@ -101,10 +109,10 @@ pcIsEmpty pc = Map.null (networkClients pc)
 
 data PresenceState = PresenceState
     { clients :: TVar (Map ConnectionKey ClientState)
-    , clientsByUser :: TVar (Map Text PresenceContainer)
+    , clientsByUser :: TVar (Map Text LocalPresence)
     , remotesByPeer :: TVar (Map ConnectionKey
                                  (Map UserName
-                                      (Map ResourceName ())))
+                                      RemotePresence))
     , associatedPeers :: TVar (Map SockAddr ())
     , server :: TMVar XMPPServer
     , keyToChan :: TVar (Map ConnectionKey Conn)
@@ -192,8 +200,11 @@ tellClientHisName state k = forClient state k fallback go
 
 toMapUnit xs = Map.fromList $ map (,()) xs
 
-resolveAllPeers hosts = fmap (toMapUnit . concat) $ mapM (fmap (take 1) . resolvePeer) hosts
+resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts
 
+rosterGetStuff
+  :: (L.ByteString -> IO [L.ByteString])
+     -> PresenceState -> ConnectionKey -> IO [Text]
 rosterGetStuff what state k = forClient state k (return [])
     $ \client -> do
     jids <- 
@@ -221,7 +232,29 @@ rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 data Conn = Conn { connChan :: TChan Stanza
                  , auxAddr :: SockAddr }
 
-sendProbesAndSlocitations state k chan = do
+textAdapter what u = fmap (map lazyByteStringToText)
+                        $ what (textToLazyByteString u)
+
+getBuddies' :: Text -> IO [Text]
+getBuddies' = textAdapter ConfigFiles.getBuddies
+getSolicited' :: Text -> IO [Text]
+getSolicited' = textAdapter ConfigFiles.getSolicited
+
+sendProbesAndSolicitations state k chan = do
+    cbu <- atomically $ readTVar $ clientsByUser state
+    -- get all buddies & solicited matching k for all users
+    us <- runTraversableT $ do
+            user <- liftT $ Map.keys cbu
+            (isbud,getter) <- liftT [(True ,getBuddies'  )
+                                    ,(False,getSolicited')]
+            bud  <- liftMT $ getter user
+            let (u,h,r) = splitJID bud
+            addr <- liftMT $ resolvePeer h
+            liftT $ guard (PeerKey addr == k)
+            return (isbud,u)
+    
+    let _ = us :: [(Bool,Maybe UserName)]
+    -- send probes for buddies, solicitations for solicited.
     return ()
 
 newConn state k addr outchan = do
@@ -229,7 +262,7 @@ newConn state k addr outchan = do
         $ Map.insert k Conn { connChan = outchan
                             , auxAddr  = addr }
     when (isPeerKey k)
-        $ sendProbesAndSlocitations state k outchan
+        $ sendProbesAndSolicitations state k outchan
 
 eofConn state k = atomically $ modifyTVar' (keyToChan state) $ Map.delete k