1 files changed, 28 insertions, 17 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 19e721b0..cf7aca70 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -8,6 +8,8 @@ module XMPPServer
     ( xmppServer
     , quitXmpp
     , ConnectionKey(..)
+    , ConnectionData(..)
+    , ConnectionType(..)
     , XMPPServerParameters(..)
     , XMPPServer
     , xmppConnections
@@ -202,7 +204,7 @@ data XMPPServerParameters =
     , xmppTellMyNameToPeer   :: SockAddr -> IO Text
     , xmppTellClientHisName  :: ConnectionKey -> IO Text
     , xmppTellPeerHisName    :: ConnectionKey -> IO Text
-    , xmppNewConnection      :: ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
+    , xmppNewConnection      :: ConnectionKey -> ConnectionData -> TChan Stanza -> IO ()
     , xmppEOF                :: ConnectionKey -> IO ()
     , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
     , xmppRosterSubscribers  :: ConnectionKey -> IO [Text]
@@ -902,7 +904,7 @@ makePong namespace mid to from =
        ]
 
 
-xmppInbound :: Server ConnectionKey SockAddr releaseKey XML.Event
+xmppInbound :: Server ConnectionKey ConnectionData releaseKey XML.Event
                 -> XMPPServerParameters
                 -> ConnectionKey
                 -> SockAddr
@@ -1250,16 +1252,16 @@ slotsToSource slots nesting lastStanza needsFlush rdone =
                 ,readTMVar rdone >> return (return ())
                 ]
 
-forkConnection :: Server ConnectionKey SockAddr releaseKey XML.Event
+forkConnection :: Server ConnectionKey ConnectionData releaseKey XML.Event
                 -> XMPPServerParameters
                 -> ConnectionKey
-                -> SockAddr
+                -> ConnectionData
                 -> FlagCommand
                 -> Source IO XML.Event
                 -> Sink (Flush XML.Event) IO ()
                 -> TChan Stanza
                 ->  IO (TChan Stanza)
-forkConnection sv xmpp k laddr pingflag src snk stanzas = do
+forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
     let (namespace,tellmyname) = case k of
                         ClientKey {} -> ("jabber:client", xmppTellMyNameToClient xmpp k)
                         PeerKey {} -> ("jabber:server",xmppTellMyNameToPeer xmpp laddr)
@@ -1404,7 +1406,7 @@ data PeerState
     | PeerConnected (TChan Stanza)
 -}
 
-peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (ConnectionKey,SockAddr)
+peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (ConnectionKey,ConnectionData)
 peerKey outgoingPeerPort sock = do
     addr <- getSocketName sock
     peer <-
@@ -1413,13 +1415,13 @@ peerKey outgoingPeerPort sock = do
              else return addr      -- Weird hack: addr is would-be peer name
     laddr <- getSocketName sock
     let peerport = fromMaybe 5269 $ outgoingPeerPort >>= sockAddrPort
-    return $ (PeerKey (peer `withPort` fromIntegral peerport),laddr)
+    return $ (PeerKey (peer `withPort` fromIntegral peerport),ConnectionData laddr XMPP)
 
-clientKey :: SocketLike sock => sock -> IO (ConnectionKey,SockAddr)
+clientKey :: SocketLike sock => sock -> IO (ConnectionKey,ConnectionData)
 clientKey sock = do
     addr <- getSocketName sock
     paddr <- getPeerName sock
-    return $ (ClientKey addr,paddr)
+    return $ (ClientKey addr,ConnectionData paddr XMPP)
 
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
 xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
@@ -1488,7 +1490,7 @@ sendRoster query xmpp clientKey replyto = do
     -}
 
 
-socketFromKey :: Server ConnectionKey SockAddr releaseKey XML.Event -> ConnectionKey -> IO SockAddr
+socketFromKey :: Server ConnectionKey ConnectionData releaseKey XML.Event -> ConnectionKey -> IO SockAddr
 socketFromKey sv k = do
     map <- atomically $ readTVar (conmap sv)
     let mcd = Map.lookup k map
@@ -1498,7 +1500,7 @@ socketFromKey sv k = do
                     PeerKey addr -> return addr
                         -- XXX: ? wrong address
                         -- Shouldnt happen anyway.
-        Just cd -> return $ cdata cd
+        Just cd -> return $ cdAddr $ cdata cd
 
 class StanzaFirstTag a where
     stanzaFirstTag :: StanzaWrap a -> IO XML.Event
@@ -1658,8 +1660,8 @@ makeErrorStanza stanza = do
            ]
 
 monitor ::
-    Server ConnectionKey SockAddr releaseKey XML.Event
-    -> ConnectionParameters ConnectionKey SockAddr
+    Server ConnectionKey ConnectionData releaseKey XML.Event
+    -> ConnectionParameters ConnectionKey ConnectionData
     -> XMPPServerParameters
     -> IO b
 monitor sv params xmpp = do
@@ -1823,13 +1825,22 @@ monitor sv params xmpp = do
         where
             _ = str :: String
 
+data ConnectionType = XMPP | Tox
+    deriving (Eq,Ord,Enum,Show,Read)
+
+data ConnectionData = ConnectionData
+    { cdAddr :: SockAddr
+    , cdType :: ConnectionType
+    }
+    deriving (Eq,Ord,Show)
+
 data XMPPServer
     = forall releaseKey.
-      XMPPServer { _xmpp_sv :: Server ConnectionKey SockAddr releaseKey XML.Event
-                 , _xmpp_peer_params :: ConnectionParameters ConnectionKey SockAddr
+      XMPPServer { _xmpp_sv :: Server ConnectionKey ConnectionData releaseKey XML.Event
+                 , _xmpp_peer_params :: ConnectionParameters ConnectionKey ConnectionData
                  }
 
-grokPeer :: XMPPServer -> ConnectionKey -> (SockAddr, ConnectionParameters ConnectionKey SockAddr, Miliseconds)
+grokPeer :: XMPPServer -> ConnectionKey -> (SockAddr, ConnectionParameters ConnectionKey ConnectionData, Miliseconds)
 grokPeer sv (PeerKey addr) = (addr, _xmpp_peer_params sv, 10000)
 
 xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text)
@@ -1838,7 +1849,7 @@ xmppConnections xsv@XMPPServer{_xmpp_sv=sv} = tcpManager (grokPeer xsv) (Just .
     resolvPeer :: Text -> IO (Maybe ConnectionKey)
     resolvPeer str = fmap PeerKey <$> listToMaybe <$> resolvePeer str
 
-xmppEventChannel :: XMPPServer -> TChan ((ConnectionKey, SockAddr), ConnectionEvent Event)
+xmppEventChannel :: XMPPServer -> TChan ((ConnectionKey, ConnectionData), ConnectionEvent Event)
 xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
 
 quitXmpp :: XMPPServer -> IO ()