summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/XMPP.hs19
-rw-r--r--Presence/main.hs22
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
493handlePeerPresence (session,jids) stanza False = do 489handlePeerPresence 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)
501handlePeerPresence (session,jids) stanza True = do 494handlePeerPresence 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
546isPresenceOf _ _ = False 535isPresenceOf _ _ = False
547 536
548fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) => 537fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) =>
549 (session, TVar (Set JID)) -> Sink XML.Event m () 538 session -> Sink XML.Event m ()
550fromPeer session = doNestingXML $ do 539fromPeer 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
67instance XMPPSession UnixSession where 68instance 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
109subscribeToChan tmvar = 127subscribeToChan tmvar =