3 files changed, 45 insertions, 34 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 678a5c99..daa93716 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -369,7 +369,7 @@ rosterGetSubscribers :: PresenceState -> ConnectionKey -> IO [Text]
 rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 
 data Conn = Conn { connChan :: TChan Stanza
-                 , auxAddr :: SockAddr }
+                 , auxData  :: ConnectionData }
 
 -- Read config file as Text content rather than UTF8 bytestrings.
 configText :: Functor f =>
@@ -448,13 +448,13 @@ sendProbesAndSolicitations state k laddr chan = do
         atomically $ writeTChan chan stanza
     -- reverse xs `seq` return ()
 
-newConn :: PresenceState -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
-newConn state k addr outchan = do
+newConn :: PresenceState -> ConnectionKey -> ConnectionData -> TChan Stanza -> IO ()
+newConn state k cdta outchan = do
     atomically $ modifyTVar' (keyToChan state)
         $ Map.insert k Conn { connChan = outchan
-                            , auxAddr  = addr }
+                            , auxData = cdta }
     when (isPeerKey k)
-        $ sendProbesAndSolicitations state k addr outchan
+        $ sendProbesAndSolicitations state k (cdAddr cdta) outchan
 
 delclient :: (Alternative m, Monad m) =>
            ConnectionKey -> m LocalPresence -> m LocalPresence
@@ -582,8 +582,8 @@ deliverMessage state fail msg =
         fromMaybe fail {- reverse lookup failure -} $ mto <&> \(to',addr) -> do
         let k = PeerKey addr
         chans <- atomically $ readTVar (keyToChan state)
-        fromMaybe fail $ (Map.lookup k chans) <&> \(Conn { connChan=chan
-                                                        , auxAddr=laddr }) -> do
+        fromMaybe fail $ (Map.lookup k chans) <&> \(Conn { connChan = chan
+                                                        , auxData = ConnectionData laddr ctyp }) -> do
         (n,r) <- forClient state senderk (return (Nothing,Nothing))
                         $ \c -> return (Just (clientUser c), Just (clientResource c))
         -- original 'from' address is discarded.
@@ -594,8 +594,8 @@ deliverMessage state fail msg =
       NetworkOrigin senderk@(PeerKey {}) _ -> do
         key_to_chan <- atomically $ readTVar (keyToChan state)
         fromMaybe fail $ (Map.lookup senderk key_to_chan)
-            <&> \(Conn { connChan=sender_chan
-                       , auxAddr=laddr }) -> do
+            <&> \(Conn { connChan = sender_chan
+                       , auxData  = ConnectionData laddr ctyp }) -> do
         fromMaybe fail $ (stanzaTo msg) <&> \to -> do
         (mine,(n,h,r)) <- rewriteJIDForClient laddr to []
         if not mine then fail else do
@@ -669,7 +669,7 @@ subscribedPeers user profile = do
 -- | this JID is suitable for peers, not clients.
 clientJID :: Conn -> ClientState -> Text
 clientJID con client = unsplitJID ( Just $ clientUser client
-                                  , addrToText $ auxAddr con
+                                  , addrToText $ cdAddr $ auxData con
                                   , Just $ clientResource client)
 
 -- | Send presence notification to subscribed peers.
@@ -790,9 +790,9 @@ answerProbe state mto k chan = do
         conn <- liftT $ Map.lookup k ktc
         let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
                                    --  probes.  Is this correct? Check the spec.
-        liftMT $ guardPortStrippedAddress h (auxAddr conn)
+        liftMT $ guardPortStrippedAddress h (cdAddr $ auxData conn)
         u <- liftT mu
-        let ch      = addrToText (auxAddr conn)
+        let ch      = addrToText (cdAddr $ auxData conn)
             profile = fromMaybe "." $ clientProfile <$> Map.lookup k cmap
         return (u,profile,conn,ch)
 
@@ -1004,7 +1004,7 @@ clientSubscriptionRequest state fail k stanza chan = do
             -- if already connected, send solicitation ...
             -- let from = clientJID con client
             let from = unsplitJID ( Just $ clientUser client
-                                  , addrToText $ auxAddr con
+                                  , addrToText $ cdAddr $ auxData con
                                   , Nothing )
             mb <- rewriteJIDForPeer to
             forM_ mb $ \(to',addr) -> do
@@ -1061,7 +1061,7 @@ peerSubscriptionRequest state fail k stanza chan = do
     (ktc,cmap) <- atomically $ (,) <$> readTVar (keyToChan state)
                                    <*> readTVar (clients state)
     fromMaybe fail $ (Map.lookup k ktc)
-        <&> \Conn { auxAddr=laddr } -> do
+        <&> \Conn { auxData=ConnectionData laddr ctyp } -> do
     (mine,totup) <- rewriteJIDForClient laddr to []
     if not mine then fail else do
     (_,fromtup) <- rewriteJIDForClient laddr from []
@@ -1205,7 +1205,7 @@ peerInformSubscription state fail k stanza = do
                                    <*> readTVar (clients state)
     fromMaybe fail $ (Map.lookup k ktc)
         <&> \(Conn { connChan=sender_chan
-                   , auxAddr=laddr }) -> do
+                   , auxData =ConnectionData laddr ctyp }) -> do
     (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from []
     let from'' = unsplitJID (from_u,from_h,Nothing)
         muser = do
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 ()
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 17e62cd7..0731d322 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1383,7 +1383,7 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar, ncPacketQueue
 -- order to set up translating conduits that simulate a remote XMPP server.
 announceToxJabberPeer :: PublicKey  -- ^ This node's long-term user key.
                       -> PublicKey -- ^ Remote tox node's long-term user key.
-                      -> TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event)
+                      -> TChan ((ConnectionKey,ConnectionData), Tcp.ConnectionEvent XML.Event)
                       -> SockAddr -- ^ Local bind address for incoming Tox packets.
                       -> SockAddr -- ^ Remote address for this connection.
                       -> STM Bool
@@ -1393,7 +1393,7 @@ announceToxJabberPeer :: PublicKey  -- ^ This node's long-term user key.
 announceToxJabberPeer me them echan laddr saddr pingflag tsrc tsnk
     = do
      atomically $ writeTChan echan
-        ( (PeerKey saddr, laddr )
+        ( (PeerKey saddr, ConnectionData laddr XMPPServer.Tox )
         , Tcp.Connection pingflag xsrc xsnk )
      return Nothing
  where