diff options
-rw-r--r-- | Presence/XMPP.hs | 19 | ||||
-rw-r--r-- | Presence/main.hs | 22 |
2 files changed, 24 insertions, 17 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 01852f43..9dfee14e 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs | |||
@@ -478,27 +478,20 @@ handlePeer st src snk = do | |||
478 | session_factory = hHead st' | 478 | session_factory = hHead st' |
479 | name <- fmap bshow $ getPeerName sock | 479 | name <- fmap bshow $ getPeerName sock |
480 | L.putStrLn $ "(P) connected " <++> name | 480 | L.putStrLn $ "(P) connected " <++> name |
481 | jids <- newTVarIO Set.empty | ||
482 | session <- newSession session_factory sock | 481 | session <- newSession session_factory sock |
483 | 482 | ||
484 | finally ( src $= parseBytes def $$ fromPeer (session,jids) ) | 483 | finally ( src $= parseBytes def $$ fromPeer session ) |
485 | $ do | 484 | $ do |
486 | L.putStrLn $ "(P) disconnected " <++> name | 485 | L.putStrLn $ "(P) disconnected " <++> name |
487 | js <- fmap Set.toList (readTVarIO jids) | ||
488 | let offline jid = Presence jid Offline | ||
489 | forM_ js $ announcePresence session . offline | ||
490 | closeSession session | 486 | closeSession session |
491 | 487 | ||
492 | 488 | ||
493 | handlePeerPresence (session,jids) stanza False = do | 489 | handlePeerPresence session stanza False = do |
494 | -- Offline | 490 | -- Offline |
495 | withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do | 491 | withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do |
496 | peer_jid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid]) | 492 | peer_jid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid]) |
497 | liftIO . atomically $ do | ||
498 | jids_ <- readTVar jids | ||
499 | writeTVar jids (Set.delete peer_jid jids_) | ||
500 | liftIO $ announcePresence session (Presence peer_jid Offline) | 493 | liftIO $ announcePresence session (Presence peer_jid Offline) |
501 | handlePeerPresence (session,jids) stanza True = do | 494 | handlePeerPresence session stanza True = do |
502 | -- online (Available or Away) | 495 | -- online (Available or Away) |
503 | let log = liftIO . L.putStrLn . ("(P) " <++>) | 496 | let log = liftIO . L.putStrLn . ("(P) " <++>) |
504 | withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do | 497 | withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do |
@@ -517,10 +510,6 @@ handlePeerPresence (session,jids) stanza True = do | |||
517 | toStat "chat" = Available | 510 | toStat "chat" = Available |
518 | 511 | ||
519 | stat' <- parseChildren Available | 512 | stat' <- parseChildren Available |
520 | |||
521 | liftIO . atomically $ do | ||
522 | jids_ <- readTVar jids | ||
523 | writeTVar jids (Set.insert pjid jids_) | ||
524 | liftIO $ announcePresence session (Presence pjid stat') | 513 | liftIO $ announcePresence session (Presence pjid stat') |
525 | log $ bshow (Presence pjid stat') | 514 | log $ bshow (Presence pjid stat') |
526 | 515 | ||
@@ -546,7 +535,7 @@ isPresenceOf (EventBeginElement name attrs) testType | |||
546 | isPresenceOf _ _ = False | 535 | isPresenceOf _ _ = False |
547 | 536 | ||
548 | fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) => | 537 | fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) => |
549 | (session, TVar (Set JID)) -> Sink XML.Event m () | 538 | session -> Sink XML.Event m () |
550 | fromPeer session = doNestingXML $ do | 539 | fromPeer session = doNestingXML $ do |
551 | let log = liftIO . L.putStrLn . ("(P) " <++>) | 540 | let log = liftIO . L.putStrLn . ("(P) " <++>) |
552 | withXML $ \begindoc -> do | 541 | withXML $ \begindoc -> do |
diff --git a/Presence/main.hs b/Presence/main.hs index 816d1537..9c11baae 100644 --- a/Presence/main.hs +++ b/Presence/main.hs | |||
@@ -61,20 +61,25 @@ data UnixSession = UnixSession { | |||
61 | localhost :: Peer, -- ByteString, | 61 | localhost :: Peer, -- ByteString, |
62 | unix_uid :: (IORef (Maybe UserID)), | 62 | unix_uid :: (IORef (Maybe UserID)), |
63 | unix_resource :: (IORef (Maybe L.ByteString)), | 63 | unix_resource :: (IORef (Maybe L.ByteString)), |
64 | announced :: TVar (Set JID), | ||
64 | presence_state :: PresenceState | 65 | presence_state :: PresenceState |
65 | } | 66 | } |
66 | 67 | ||
67 | instance XMPPSession UnixSession where | 68 | instance XMPPSession UnixSession where |
68 | data XMPPClass UnixSession = UnixSessions PresenceState | 69 | data XMPPClass UnixSession = UnixSessions PresenceState |
70 | |||
69 | newSession (UnixSessions state) sock = do | 71 | newSession (UnixSessions state) sock = do |
70 | muid <- getLocalPeerCred sock | 72 | muid <- getLocalPeerCred sock |
71 | L.putStrLn $ "SESSION: open " <++> bshow muid | 73 | L.putStrLn $ "SESSION: open " <++> bshow muid |
72 | uid_ref <- newIORef muid | 74 | uid_ref <- newIORef muid |
73 | res_ref <- newIORef Nothing | 75 | res_ref <- newIORef Nothing |
74 | return $ UnixSession (hostname state) uid_ref res_ref state | 76 | jids <- newTVarIO Set.empty |
77 | return $ UnixSession (hostname state) uid_ref res_ref jids state | ||
78 | |||
75 | setResource s resource = do | 79 | setResource s resource = do |
76 | writeIORef (unix_resource s) (Just resource) | 80 | writeIORef (unix_resource s) (Just resource) |
77 | L.putStrLn $ "SESSION: resource " <++> resource | 81 | L.putStrLn $ "SESSION: resource " <++> resource |
82 | |||
78 | getJID s = do | 83 | getJID s = do |
79 | let host = localhost s | 84 | let host = localhost s |
80 | muid <- readIORef (unix_uid s) | 85 | muid <- readIORef (unix_uid s) |
@@ -91,19 +96,32 @@ instance XMPPSession UnixSession where | |||
91 | -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc | 96 | -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc |
92 | L.putStrLn $ "SESSION: jid " <++> L.show (JID (Just user) host rsc) | 97 | L.putStrLn $ "SESSION: jid " <++> L.show (JID (Just user) host rsc) |
93 | return (JID (Just user) host rsc) | 98 | return (JID (Just user) host rsc) |
94 | closeSession _ = L.putStrLn "SESSION: close" | 99 | |
100 | closeSession session = do | ||
101 | L.putStrLn "SESSION: close" | ||
102 | js <- fmap Set.toList (readTVarIO . announced $ session) | ||
103 | let offline jid = Presence jid Offline | ||
104 | forM_ js $ announcePresence session . offline | ||
105 | |||
95 | subscribe session Nothing = do | 106 | subscribe session Nothing = do |
96 | let tmvar = localSubscriber (presence_state session) | 107 | let tmvar = localSubscriber (presence_state session) |
97 | atomically $ subscribeToChan tmvar | 108 | atomically $ subscribeToChan tmvar |
98 | subscribe session (Just jid) = do -- UNUSED as yet | 109 | subscribe session (Just jid) = do -- UNUSED as yet |
99 | let tvar = subscriberMap (presence_state session) | 110 | let tvar = subscriberMap (presence_state session) |
100 | atomically $ subscribeToMap tvar jid | 111 | atomically $ subscribeToMap tvar jid |
112 | |||
101 | announcePresence session (Presence jid status) = do | 113 | announcePresence session (Presence jid status) = do |
102 | (greedy,subs) <- atomically $ do | 114 | (greedy,subs) <- atomically $ do |
103 | subs <- readTVar $ subscriberMap (presence_state session) | 115 | subs <- readTVar $ subscriberMap (presence_state session) |
104 | greedy <- fmap snd $ readTMVar $ localSubscriber (presence_state session) | 116 | greedy <- fmap snd $ readTMVar $ localSubscriber (presence_state session) |
105 | return (greedy,subs) | 117 | return (greedy,subs) |
106 | update_presence (Just greedy) (fmap snd subs) (Set.singleton jid) (const status) | 118 | update_presence (Just greedy) (fmap snd subs) (Set.singleton jid) (const status) |
119 | liftIO . atomically $ do | ||
120 | jids <- readTVar . announced $ session | ||
121 | writeTVar (announced session) | ||
122 | $ case status of | ||
123 | Offline -> Set.delete jid jids | ||
124 | _ -> Set.insert jid jids | ||
107 | 125 | ||
108 | 126 | ||
109 | subscribeToChan tmvar = | 127 | subscribeToChan tmvar = |