summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/XMPP.hs29
-rw-r--r--Presence/main.hs1
2 files changed, 20 insertions, 10 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 0fd49c2b..89fd420f 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -583,6 +583,11 @@ data OutBoundMessage = OutBoundPresence Presence | PresenceProbe JID
583 583
584newServerConnections = newTVar Map.empty 584newServerConnections = newTVar Map.empty
585 585
586data CachedMessages = CachedMessages
587 { presences :: Map JID JabberShow
588 , probes :: Set JID
589 }
590
586connect_to_server chan peer = (>> return ()) . runMaybeT $ do 591connect_to_server chan peer = (>> return ()) . runMaybeT $ do
587 let port = 5269 :: Int 592 let port = 5269 :: Int
588 593
@@ -590,7 +595,7 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
590 595
591 -- We'll cache Presence notifications until the socket 596 -- We'll cache Presence notifications until the socket
592 -- is ready. 597 -- is ready.
593 cached <- liftIO $ newIORef Map.empty 598 cached <- liftIO $ newIORef (CachedMessages Map.empty Set.empty)
594 599
595 sock <- MaybeT . fix $ \loop -> do 600 sock <- MaybeT . fix $ \loop -> do
596 e <- atomically $ orElse 601 e <- atomically $ orElse
@@ -598,15 +603,16 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
598 (fmap Left $ readTChan chan) 603 (fmap Left $ readTChan chan)
599 case e of 604 case e of
600 Left (OutBoundPresence (Presence jid Offline)) -> do 605 Left (OutBoundPresence (Presence jid Offline)) -> do
601 cached_map <- readIORef cached 606 cache <- readIORef cached
602 writeIORef cached (Map.delete jid cached_map) 607 writeIORef cached (cache { presences=Map.delete jid . presences $ cache })
603 loop 608 loop
604 Left (OutBoundPresence p@(Presence jid st)) -> do 609 Left (OutBoundPresence p@(Presence jid st)) -> do
605 cached_map <- readIORef cached 610 cache <- readIORef cached
606 writeIORef cached (Map.insert jid st cached_map) 611 writeIORef cached (cache { presences=Map.insert jid st . presences $ cache })
607 loop 612 loop
608 Left (PresenceProbe jid) -> do 613 Left (PresenceProbe jid) -> do
609 liftIO $ putStrLn "Connection not ready, Discarding Presence Probe..." 614 cache <- readIORef cached
615 writeIORef cached (cache { probes=Set.insert jid . probes $ cache })
610 loop 616 loop
611 {- 617 {-
612 Left event -> do 618 Left event -> do
@@ -619,8 +625,9 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do
619 h <- socketToHandle sock ReadWriteMode 625 h <- socketToHandle sock ReadWriteMode
620 hSetBuffering h NoBuffering 626 hSetBuffering h NoBuffering
621 let snk = packetSink h 627 let snk = packetSink h
622 cache <- fmap Map.assocs . readIORef $ cached 628 cache <- readIORef $ cached
623 writeIORef cached Map.empty -- hint garbage collector: we're done with this 629 -- hint garbage collector: we're done with this...
630 writeIORef cached (CachedMessages Map.empty Set.empty)
624 handleOutgoingToPeer (restrictSocket sock) cache chan snk 631 handleOutgoingToPeer (restrictSocket sock) cache chan snk
625 632
626 633
@@ -641,9 +648,12 @@ toPeer sock cache chan = do
641 let -- log = liftIO . L.putStrLn . ("(>P) " <++>) 648 let -- log = liftIO . L.putStrLn . ("(>P) " <++>)
642 send xs = yield xs >> prettyPrint ">P: " xs 649 send xs = yield xs >> prettyPrint ">P: " xs
643 send greetPeer 650 send greetPeer
644 forM_ cache $ \(jid,st) -> do 651 forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
645 r <- lift $ xmlifyPresenceForPeer sock (Presence jid st) 652 r <- lift $ xmlifyPresenceForPeer sock (Presence jid st)
646 send r 653 send r
654 forM_ (Set.toList . probes $ cache) $ \jid -> do
655 -- TODO: send probe
656 return ()
647 fix $ \loop -> do 657 fix $ \loop -> do
648 event <- lift . atomically $ readTChan chan 658 event <- lift . atomically $ readTChan chan
649 case event of 659 case event of
@@ -651,6 +661,7 @@ toPeer sock cache chan = do
651 r <- lift $ xmlifyPresenceForPeer sock p 661 r <- lift $ xmlifyPresenceForPeer sock p
652 send r 662 send r
653 PresenceProbe jid -> do 663 PresenceProbe jid -> do
664 -- TODO: send probe
654 liftIO $ putStrLn ("Connection ready, PresenceProbe " ++ show jid ++ " (NOT IMPLEMENTED)") 665 liftIO $ putStrLn ("Connection ready, PresenceProbe " ++ show jid ++ " (NOT IMPLEMENTED)")
655 loop 666 loop
656 send goodbyePeer 667 send goodbyePeer
diff --git a/Presence/main.hs b/Presence/main.hs
index fa4a98c1..2c0a6cfb 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -246,7 +246,6 @@ sendProbes state jid = do
246 jids <- maybe (return Set.empty) readTVarIO mjids 246 jids <- maybe (return Set.empty) readTVarIO mjids
247 let noinfo = Set.notMember buddy jids 247 let noinfo = Set.notMember buddy jids
248 when noinfo $ do 248 when noinfo $ do
249 -- TODO ... sendMessage
250 sendMessage (outGoingConnections state) (PresenceProbe buddy) (peer buddy) 249 sendMessage (outGoingConnections state) (PresenceProbe buddy) (peer buddy)
251 return () 250 return ()
252 251