diff options
-rw-r--r-- | Presence/XMPP.hs | 29 | ||||
-rw-r--r-- | Presence/main.hs | 1 |
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 | ||
584 | newServerConnections = newTVar Map.empty | 584 | newServerConnections = newTVar Map.empty |
585 | 585 | ||
586 | data CachedMessages = CachedMessages | ||
587 | { presences :: Map JID JabberShow | ||
588 | , probes :: Set JID | ||
589 | } | ||
590 | |||
586 | connect_to_server chan peer = (>> return ()) . runMaybeT $ do | 591 | connect_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 | ||