Split UnixSession structure into ClientSession and PeerSession.

1 files changed, 42 insertions, 23 deletions

diff --git a/Presence/main.hs b/Presence/main.hs
index 9c11baae..f17b8340 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -57,28 +57,26 @@ import qualified Text.Show.ByteString as L
 import Network.Socket (Family(AF_INET,AF_INET6))
 
 
-data UnixSession = UnixSession {
+data ClientSession = ClientSession {
     localhost :: Peer, -- ByteString,
     unix_uid :: (IORef (Maybe UserID)),
     unix_resource :: (IORef (Maybe L.ByteString)),
-    announced :: TVar (Set JID),
     presence_state :: PresenceState
 }
 
-instance XMPPSession UnixSession where
-    data XMPPClass UnixSession = UnixSessions PresenceState
+instance XMPPSession ClientSession where
+    data XMPPClass ClientSession = ClientSessions PresenceState
 
-    newSession (UnixSessions state) sock = do
+    newSession (ClientSessions state) sock = do
         muid <- getLocalPeerCred sock
-        L.putStrLn $ "SESSION: open " <++> bshow muid
+        L.putStrLn $ "CLIENT SESSION: open " <++> bshow muid
         uid_ref <- newIORef muid
         res_ref <- newIORef Nothing
-        jids <- newTVarIO Set.empty
-        return $ UnixSession (hostname state) uid_ref res_ref jids state
+        return $ ClientSession (hostname state) uid_ref res_ref state
 
     setResource  s  resource    = do
         writeIORef (unix_resource s) (Just resource)
-        L.putStrLn $ "SESSION: resource " <++> resource
+        L.putStrLn $ "CLIENT SESSION: resource " <++> resource
 
     getJID       s             = do
         let host = localhost s
@@ -94,14 +92,11 @@ instance XMPPSession UnixSession where
                    muid
         rsc <- readIORef (unix_resource s)
         -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc
-        L.putStrLn $ "SESSION: jid " <++> L.show (JID (Just user) host rsc)
+        L.putStrLn $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc)
         return (JID (Just user) host rsc)
 
     closeSession session  = do
-        L.putStrLn "SESSION: close"
-        js <- fmap Set.toList (readTVarIO . announced $ session)
-        let offline jid = Presence jid Offline
-        forM_ js $ announcePresence session . offline
+        L.putStrLn "CLIENT SESSION: close"
 
     subscribe session Nothing = do
         let tmvar = localSubscriber (presence_state session)
@@ -110,10 +105,35 @@ instance XMPPSession UnixSession where
         let tvar = subscriberMap (presence_state session)
         atomically $ subscribeToMap tvar jid
 
+    announcePresence _ _ = error "announcePresence on client session?"
+
+
+data PeerSession = PeerSession {
+    announced :: TVar (Set JID),
+    peer_global :: PresenceState
+}
+instance XMPPSession PeerSession where
+    data XMPPClass PeerSession = PeerSessions PresenceState
+
+    setResource _ _ = error "setResource on peer session?"
+    getJID _        = error "getJID on peer session?"
+    subscribe _ _   = error "subscribe on peer session?"
+
+    newSession (PeerSessions state) sock = do
+        L.putStrLn $ "PEER SESSION: open"
+        jids <- newTVarIO Set.empty
+        return $ PeerSession jids state
+
+    closeSession session  = do
+        L.putStrLn "PEER SESSION: close"
+        js <- fmap Set.toList (readTVarIO . announced $ session)
+        let offline jid = Presence jid Offline
+        forM_ js $ announcePresence session . offline
+
     announcePresence session (Presence jid status) = do
         (greedy,subs) <- atomically $ do
-            subs <- readTVar $ subscriberMap (presence_state session)
-            greedy <- fmap snd $ readTMVar $ localSubscriber (presence_state session)
+            subs <- readTVar $ subscriberMap (peer_global session)
+            greedy <- fmap snd $ readTMVar $ localSubscriber (peer_global session)
             return (greedy,subs)
         update_presence (Just greedy) (fmap snd subs) (Set.singleton jid) (const status)
         liftIO . atomically $ do
@@ -123,7 +143,6 @@ instance XMPPSession UnixSession where
                     Offline -> Set.delete jid jids
                     _       -> Set.insert jid jids
 
-
 subscribeToChan tmvar =
             (do (cnt,chan) <- takeTMVar tmvar
                 putTMVar tmvar (cnt+1,chan)
@@ -229,16 +248,16 @@ instance XMPPConfig UnixConfig where
 start :: Network.Socket.Family -> IO ()
 start ip4or6 = do
     let host = LocalHost
-    tracked <- newPresenceState host
-    let dologin e = track_login host tracked e
+    global_state <- newPresenceState host
+    let dologin e = track_login host global_state e
         dologin :: t -> IO ()
 
-    chan <- atomically $ subscribeToChan (localSubscriber tracked)
+    chan <- atomically $ subscribeToChan (localSubscriber global_state)
     remotes <- forkIO $ seekRemotePeers UnixConfig chan
 
     installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
     -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
-    mtty <- monitorTTY (on_chvt tracked)
+    mtty <- monitorTTY (on_chvt global_state)
     inotify <- initINotify
 #ifndef NOUTMP
     wd <- addWatch
@@ -247,8 +266,8 @@ start ip4or6 = do
             utmp_file
             dologin
 #endif
-    clients <- listenForXmppClients ip4or6 (UnixSessions tracked) 5222 HNil
-    peers   <- listenForRemotePeers ip4or6 (UnixSessions tracked) 5269 HNil
+    clients <- listenForXmppClients ip4or6 (ClientSessions global_state) 5222 HNil
+    peers   <- listenForRemotePeers ip4or6 (PeerSessions global_state) 5269 HNil
 
     threadDelay 1000 -- wait a moment to obtain current tty
     dologin ()