XMPP: Type-checking on various uses of SockAddr.

1 files changed, 153 insertions, 132 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 8d294698..1de6a26a 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -7,11 +7,17 @@
 module XMPPServer
     ( xmppServer
     , quitXmpp
-    , ConnectionKey(..)
+    , ClientAddress
+    , PeerAddress
+    , Local(..)
+    , Remote(..)
     , ConnectionData(..)
     , ConnectionType(..)
     , XMPPServerParameters(..)
     , XMPPServer
+    , classifyConnection
+    , addrToPeerKey
+    , addrFromClientKey
     , xmppConnections
     , xmppEventChannel
     , StanzaWrap(..)
@@ -85,7 +91,7 @@ import Data.XML.Types as XML
 import Data.Maybe
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
-import qualified Data.Text as Text (pack,unpack,words,intercalate)
+import qualified Data.Text as Text (pack,unpack,words,intercalate,drop)
 import Data.Char (chr,ord)
 import qualified Data.Map as Map
 import Data.Set (Set, (\\) )
@@ -167,7 +173,10 @@ data StanzaType
     | InternalCacheId Text
  deriving (Show,Eq)
 
-data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
+data StanzaOrigin = LocalPeer
+                  | PeerOrigin PeerAddress (TChan Stanza)
+                  | ClientOrigin ClientAddress (TChan Stanza)
+
 
 data StanzaWrap a = Stanza
     { stanzaType :: StanzaType
@@ -182,6 +191,9 @@ data StanzaWrap a = Stanza
 
 type Stanza = StanzaWrap (LockedChan XML.Event)
 
+newtype Local a = Local a deriving (Eq,Ord,Show)
+newtype Remote a = Remote a deriving (Eq,Ord,Show)
+
 data XMPPServerParameters =
     XMPPServerParameters
     { -- | Called when a client requests a resource id.  The first Maybe indicates
@@ -190,36 +202,35 @@ data XMPPServerParameters =
       --
       -- Note: The returned domain will be discarded and replaced with the result of
       -- 'xmppTellMyNameToClient'.
-      xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text
+      xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
     , -- | This should indicate the server's hostname that all client's see.
-      xmppTellMyNameToClient :: ConnectionKey -> IO Text
-    , xmppTellMyNameToPeer   :: SockAddr -> IO Text
-    , xmppTellClientHisName  :: ConnectionKey -> IO Text
-    , xmppTellPeerHisName    :: ConnectionKey -> IO Text
-    , xmppNewConnection      :: ConnectionKey -> ConnectionData -> TChan Stanza -> IO ()
-    , xmppEOF                :: ConnectionKey -> IO ()
-    , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
-    , xmppRosterSubscribers  :: ConnectionKey -> IO [Text]
-    , xmppRosterSolicited    :: ConnectionKey -> IO [Text]
-    , xmppRosterOthers       :: ConnectionKey -> IO [Text]
+      xmppTellMyNameToClient :: ClientAddress -> IO Text
+    , xmppTellMyNameToPeer   :: Local SockAddr -> IO Text
+    , xmppTellClientHisName  :: ClientAddress -> IO Text
+    , xmppTellPeerHisName    :: PeerAddress -> IO Text
+    , xmppNewConnection      :: SockAddr -> ConnectionData -> TChan Stanza -> IO ()
+    , xmppEOF                :: SockAddr -> ConnectionData -> IO ()
+    , xmppRosterBuddies      :: ClientAddress -> IO [Text]
+    , xmppRosterSubscribers  :: ClientAddress -> IO [Text]
+    , xmppRosterSolicited    :: ClientAddress -> IO [Text]
+    , xmppRosterOthers       :: ClientAddress -> IO [Text]
     , -- | Called when after sending a roster to a client.  Usually this  means
       -- the client status should change from "available" to "interested".
-      xmppSubscribeToRoster  :: ConnectionKey -> IO ()
-    -- , xmppLookupClientJID :: ConnectionKey -> IO Text
-    , xmppTellClientNameOfPeer :: ConnectionKey -> [Text] -> IO Text
+      xmppSubscribeToRoster  :: ClientAddress -> IO ()
+    -- , xmppLookupClientJID :: SockAddr -> IO Text
     , xmppDeliverMessage     :: (IO ()) -> Stanza -> IO ()
       -- | Called whenever a local client's presence changes.
-    , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
+    , xmppInformClientPresence :: ClientAddress -> Stanza -> IO ()
       -- | Called whenever a remote peer's presence changes.
-    , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
+    , xmppInformPeerPresence :: PeerAddress -> Stanza -> IO ()
     , -- | Called when a remote peer requests our status.
-      xmppAnswerProbe        :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
-    , xmppClientSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
+      xmppAnswerProbe        :: PeerAddress -> Stanza -> TChan Stanza -> IO ()
+    , xmppClientSubscriptionRequest :: IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
     , -- | Called when a remote peer sends subscription request.
-      xmppPeerSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
-    , xmppClientInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
+      xmppPeerSubscriptionRequest :: IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
+    , xmppClientInformSubscription :: IO () -> ClientAddress -> Stanza -> IO ()
     , -- | Called when a remote peer informs us of our subscription status.
-      xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
+      xmppPeerInformSubscription :: IO () -> PeerAddress -> Stanza -> IO ()
     , xmppVerbosity          :: IO Int
     , xmppClientBind         :: Maybe SockAddr
     , xmppPeerBind           :: Maybe SockAddr
@@ -270,10 +281,9 @@ addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
           where
             (pre,bracket) = break (==']') s
 
--- Shows (as Text) the IP address associated with the given ConnectionKey.
-peerKeyToText :: ConnectionKey -> Text
-peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr
-peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
+-- Shows (as Text) the IP address associated with the given SockAddr.
+peerKeyToText :: PeerAddress -> Text
+peerKeyToText (PeerAddress addr) = addrToText addr
 
 
 wlog :: String -> IO ()
@@ -895,26 +905,17 @@ makePong namespace mid to from =
        , EventEndElement (mkname namespace "iq")
        ]
 
+data ClientOrPeer = IsClient | IsPeer
 
-xmppInbound :: Server ConnectionKey ConnectionData releaseKey XML.Event
-                -> XMPPServerParameters
-                -> ConnectionKey
-                -> SockAddr
-                -> FlagCommand  -- ^ action to check whether the connection needs a ping
+xmppInbound :: Server SockAddr ConnectionData releaseKey XML.Event -- ^ XXX: unused
+                -> XMPPServerParameters -- ^ XXX: unused
+                -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
+                -> FlagCommand  -- ^ action to check whether the connection needs a ping (XXX: unused)
                 -> TChan Stanza -- ^ channel to announce incoming stanzas on
                 -> TChan Stanza -- ^ channel used to send stanzas
                 -> TMVar ()     -- ^ mvar that is filled when the connection quits
-                -> Sink XML.Event IO ()
-xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
-    let (namespace,tellmyname,tellyourname) = case k of
-            ClientKey {} -> ( "jabber:client"
-                            , xmppTellMyNameToClient xmpp k
-                            , xmppTellClientHisName xmpp k
-                            )
-            PeerKey {} -> ( "jabber:server"
-                          , xmppTellMyNameToPeer xmpp laddr
-                          , xmppTellPeerHisName xmpp k
-                          )
+                -> ConduitM Event o IO ()
+xmppInbound sv xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
     me <- liftIO tellmyname
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
@@ -948,7 +949,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                               , stanzaChan = chan
                               , stanzaClosers = clsrs
                               , stanzaInterrupt = donevar
-                              , stanzaOrigin = NetworkOrigin k output
+                              , stanzaOrigin = mkorigin output
                               }
                 ioWriteChan stanzas s
           you <- liftIO tellyourname
@@ -973,7 +974,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                             , stanzaChan = chan
                             , stanzaClosers = clsrs
                             , stanzaInterrupt = donevar
-                            , stanzaOrigin = NetworkOrigin k output
+                            , stanzaOrigin = mkorigin output
                             }
 #endif
               stype -> ioWriteChan stanzas Stanza
@@ -986,7 +987,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                             , stanzaChan      = chan
                             , stanzaClosers   = clsrs
                             , stanzaInterrupt = donevar
-                            , stanzaOrigin    = NetworkOrigin k output
+                            , stanzaOrigin    = mkorigin output
                             }
           awaitCloser stanza_lvl
         liftIO . atomically $ writeTVar clsrs Nothing
@@ -1244,19 +1245,23 @@ slotsToSource slots nesting lastStanza needsFlush rdone =
                 ,readTMVar rdone >> return (return ())
                 ]
 
-forkConnection :: Server ConnectionKey ConnectionData releaseKey XML.Event
+forkConnection :: Server SockAddr ConnectionData releaseKey XML.Event
                 -> XMPPServerParameters
-                -> ConnectionKey
+                -> SockAddr -- SockAddr (remote for peer, local for client)
                 -> ConnectionData
                 -> FlagCommand
                 -> Source IO XML.Event
                 -> Sink (Flush XML.Event) IO ()
                 -> TChan Stanza
                 ->  IO (TChan Stanza)
-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)
+forkConnection sv xmpp saddr (ConnectionData auxAddr _) pingflag src snk stanzas = do
+    let clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
+            Right _    -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress saddr)
+                                          , xmppTellClientHisName xmpp (ClientAddress saddr)
+                                          , ClientOrigin (ClientAddress saddr))
+            Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr
+                                          , xmppTellPeerHisName xmpp (PeerAddress saddr)
+                                          , PeerOrigin (PeerAddress saddr))
     me <- tellmyname
     rdone <- atomically newEmptyTMVar
     let isStarter (Left _) = True
@@ -1274,7 +1279,11 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
             CL.sourceList (greet' namespace me) =$= CL.map Chunk
             yield Flush
         slot_src = slotsToSource slots nesting lastStanza needsFlush rdone
-    forkIO $ do myThreadId >>= flip labelThread ("post-queue."++show k)
+    let lbl n = concat [ n
+                       , Text.unpack (Text.drop 7 namespace)
+                       , "."
+                       , show saddr ]
+    forkIO $ do myThreadId >>= flip labelThread (lbl "post-queue.")
                 (greet_src >> slot_src) $$ snk
                 last <- atomically $ readTVar lastStanza
                 es <- while (atomically . fmap not $ Slotted.isEmpty slots)
@@ -1298,14 +1307,14 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                                     _ -> True
                 -- TODO: Probably some stanzas should be queued or saved for re-connect.
                 mapM_ fail $ filter notError (maybeToList last ++ es')
-                wlog $ "end post-queue fork: " ++ show k
+                wlog $ "end post-queue fork: " ++ (lbl "")
 
     output <- atomically newTChan
     hacks <- atomically $ newTVar Map.empty
     msgids <- atomically $ newTVar []
     forkIO $ do
         -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
-        myThreadId >>= flip labelThread ("pre-queue."++show k)
+        myThreadId >>= flip labelThread (lbl "pre-queue.")
         verbosity <- xmppVerbosity xmpp
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
@@ -1320,9 +1329,9 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                     notping $ do
                         dup <- cloneStanza stanza
                         let typ = Strict8.pack $ c ++ "<-"++(concat . take 1 . words $ show (stanzaType dup))++" "
-                            c = case k of
-                                    ClientKey {} -> "C"
-                                    PeerKey {}   -> "P"
+                            c = case auxAddr of
+                                    Right _ -> "C"
+                                    Left  _ -> "P"
                         wlog ""
                         stanzaToConduit dup $$ prettyPrint typ
                     -- wlog $ "hacks: "++show (stanzaId stanza)
@@ -1360,7 +1369,7 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                     loop
                 ,do pingflag >>= check
                     return $ do
-                    to <- xmppTellPeerHisName xmpp k -- addrToText (callBackAddress k)
+                    to <- telltheirname
                     let from = me -- Look it up from Server object
                                   -- or pass it with Connection event.
                         mid = Just "ping"
@@ -1368,23 +1377,21 @@ forkConnection sv xmpp k (ConnectionData laddr _) pingflag src snk stanzas = do
                     ping <- atomically $ wrapStanzaList ping0
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
                           ping
-#ifdef PINGNOISE
                     wlog ""
-                    CL.sourceList ping0 $$ prettyPrint $ case k of
-                        ClientKey {} -> "C<-Ping"
-                        PeerKey {} -> "P<-Ping "
-#endif
+                    CL.sourceList ping0 $$ prettyPrint $ case auxAddr of
+                        Right _ -> "C<-Ping"
+                        Left  _ -> "P<-Ping "
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
             what
-        wlog $ "end pre-queue fork: " ++ show k
+        wlog $ "end pre-queue fork: " ++ show (lbl "")
     forkIO $ do
-        myThreadId >>= flip labelThread ("reader."++show k)
+        myThreadId >>= flip labelThread (lbl "reader.")
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        src $$ xmppInbound sv xmpp k laddr pingflag stanzas output rdone
+        src $$ xmppInbound sv xmpp clientOrServer pingflag stanzas output rdone
         atomically $ putTMVar rdone ()
-        wlog $ "end reader fork: " ++ show k
+        wlog $ "end reader fork: " ++ lbl ""
     return output
 
 {-
@@ -1398,22 +1405,22 @@ data PeerState
     | PeerConnected (TChan Stanza)
 -}
 
-peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (ConnectionKey,ConnectionData)
-peerKey outgoingPeerPort sock = do
-    addr <- getSocketName sock
-    peer <-
+peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (SockAddr,ConnectionData)
+peerKey bind_addr sock = do
+    laddr <- getSocketName sock
+    raddr <-
       sIsConnected sock >>= \c ->
         if c then getPeerName sock -- addr is normally socketName
-             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),ConnectionData laddr XMPP)
+             else return laddr     -- Weird hack: addr is would-be peer name
+    -- Assume remote peers are listening on the same port that we do.
+    let peerport = fromIntegral $ fromMaybe 5269 $ bind_addr >>= sockAddrPort
+    return $ (raddr `withPort` peerport,ConnectionData (Left (Local laddr)) XMPP)
 
-clientKey :: SocketLike sock => sock -> IO (ConnectionKey,ConnectionData)
+clientKey :: SocketLike sock => sock -> IO (SockAddr,ConnectionData)
 clientKey sock = do
-    addr <- getSocketName sock
-    paddr <- getPeerName sock
-    return $ (ClientKey addr,ConnectionData paddr XMPP)
+    laddr <- getSocketName sock
+    raddr <- getPeerName sock
+    return $ (laddr,ConnectionData (Right (Remote raddr)) XMPP)
 
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
 xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
@@ -1429,14 +1436,15 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
 sendRoster ::
     StanzaWrap a
     -> XMPPServerParameters
-    -> ConnectionKey
+    -> ClientAddress
     -> TChan Stanza
     -> IO ()
 sendRoster query xmpp clientKey replyto = do
-    let k = case stanzaOrigin query of
-             NetworkOrigin k _ -> Just k
-             LocalPeer -> Nothing -- local peer requested roster?
-    forM_ k $ \k -> do
+    let maddr = case stanzaOrigin query of
+             ClientOrigin addr _ -> Just addr
+             PeerOrigin {}       -> Nothing -- remote peer requested roster?
+             LocalPeer           -> Nothing -- local peer requested roster?
+    forM_ maddr $ \k -> do
     hostname <- xmppTellMyNameToClient xmpp clientKey
     let getlist f = do
             bs <- f xmpp k
@@ -1445,9 +1453,7 @@ sendRoster query xmpp clientKey replyto = do
     subscribers <- getlist xmppRosterSubscribers
     solicited   <- getlist xmppRosterSolicited
     subnone0    <- getlist xmppRosterOthers
-    jid <- case k of
-                ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
-                PeerKey {}   -> xmppTellClientNameOfPeer xmpp k (Set.toList buddies)
+    jid <- xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
     let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
     let subto = buddies \\ subscribers
     let subfrom = subscribers \\ buddies
@@ -1482,17 +1488,14 @@ sendRoster query xmpp clientKey replyto = do
     -}
 
 
-socketFromKey :: Server ConnectionKey ConnectionData releaseKey XML.Event -> ConnectionKey -> IO SockAddr
-socketFromKey sv k = do
+socketFromKey :: Server SockAddr ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr)
+socketFromKey sv (ClientAddress addr) = do
     map <- atomically $ readTVar (conmap sv)
-    let mcd = Map.lookup k map
+    let mcd = Map.lookup addr map
+        oops = Remote addr -- No connection data, so using incorrect address.
     case mcd of
-        Nothing -> case k of
-                    ClientKey addr -> return addr
-                    PeerKey addr -> return addr
-                        -- XXX: ? wrong address
-                        -- Shouldnt happen anyway.
-        Just cd -> return $ cdAddr $ cdata cd
+        Nothing -> return oops
+        Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd
 
 class StanzaFirstTag a where
     stanzaFirstTag :: StanzaWrap a -> IO XML.Event
@@ -1652,8 +1655,8 @@ makeErrorStanza stanza = do
            ]
 
 monitor ::
-    Server ConnectionKey ConnectionData releaseKey XML.Event
-    -> ConnectionParameters ConnectionKey ConnectionData
+    Server SockAddr ConnectionData releaseKey XML.Event
+    -> ConnectionParameters SockAddr ConnectionData
     -> XMPPServerParameters
     -> IO b
 monitor sv params xmpp = do
@@ -1662,20 +1665,25 @@ monitor sv params xmpp = do
     quitVar <- atomically newEmptyTMVar
     fix $ \loop -> do
     action <- atomically $ foldr1 orElse
-      [ readTChan chan >>= \((k,u),e) -> return $ do
+      [ readTChan chan >>= \((addr,u),e) -> return $ do
         case e of
-            Connection pingflag xsrc xsnk -> do
-                wlog $ tomsg k "Connection"
-                outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas
-                xmppNewConnection xmpp k u outs
-            ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
-            EOF        -> do wlog $ tomsg k "EOF"
-                             xmppEOF xmpp k
-            HalfConnection In -> do
-                wlog $ tomsg k "ReadOnly"
-                control sv (Connect (callBackAddress k) params)
-            HalfConnection Out -> wlog $ tomsg k "WriteOnly"
-            RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
+            Connection pingflag xsrc xsnk
+                -> do wlog $ tomsg addr "Connection"
+                      outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas
+                      xmppNewConnection xmpp addr u outs
+            ConnectFailure addr
+                -> do return () -- wlog $ tomsg k "ConnectFailure"
+            EOF -> do wlog $ tomsg addr "EOF"
+                      xmppEOF xmpp addr u
+            HalfConnection In
+                -> do wlog $ tomsg addr "ReadOnly"
+                      case cdAddr u of
+                        Left (Local _) -> control sv (Connect addr params)
+                        _              -> return () -- Don't call-back client connections.
+            HalfConnection Out
+                -> do wlog $ tomsg addr "WriteOnly"
+            RequiresPing
+                -> do return () -- wlog $ tomsg k "RequiresPing"
       , readTChan stanzas >>= \stanza -> return $ do
         {-
         dup <- case stanzaType stanza of
@@ -1692,7 +1700,7 @@ monitor sv params xmpp = do
 
         forkIO $ do
             case stanzaOrigin stanza of
-                NetworkOrigin k@(ClientKey {}) replyto ->
+                ClientOrigin k replyto ->
                     case stanzaType stanza of
                         RequestResource clientsNameForMe wanted -> do
                             sockaddr <- socketFromKey sv k
@@ -1755,7 +1763,7 @@ monitor sv params xmpp = do
                                 guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
                                 stanzaId stanza
                         _ -> return ()
-                NetworkOrigin k@(PeerKey {}) replyto ->
+                PeerOrigin k replyto ->
                     case stanzaType stanza of
                         PresenceRequestStatus {} -> do
                             xmppAnswerProbe xmpp k stanza replyto
@@ -1785,14 +1793,13 @@ monitor sv params xmpp = do
                 Message {} -> do
                   case stanzaOrigin stanza of
                     LocalPeer {} -> return ()
-                    NetworkOrigin _ replyto -> deliver replyto
+                    ClientOrigin _ replyto -> deliver replyto
+                    PeerOrigin   _ replyto -> deliver replyto
                 Error {} -> do
                   case stanzaOrigin stanza of
                     LocalPeer {} -> return ()
-                    NetworkOrigin k replyto -> do
-                         -- wlog $ "delivering error: " ++show (stanzaId stanza)
-                         -- wlog $ " from: " ++ show k
-                         deliver replyto
+                    ClientOrigin _ replyto -> deliver replyto
+                    PeerOrigin   _ replyto -> deliver replyto
                 _ -> return ()
         -- We need to clone in the case the stanza is passed on as for Message.
         verbosity <- xmppVerbosity xmpp
@@ -1803,9 +1810,9 @@ monitor sv params xmpp = do
         notping $ do
         let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
             c = case stanzaOrigin stanza of
-                    LocalPeer -> "*"
-                    NetworkOrigin (ClientKey {}) _ -> "C"
-                    NetworkOrigin (PeerKey {})   _ -> "P"
+                    LocalPeer       -> "*"
+                    ClientOrigin {} -> "C"
+                    PeerOrigin {}   -> "P"
         wlog ""
         stanzaToConduit dup $$ prettyPrint typ
 
@@ -1821,27 +1828,41 @@ data ConnectionType = XMPP | Tox
     deriving (Eq,Ord,Enum,Show,Read)
 
 data ConnectionData = ConnectionData
-    { cdAddr :: SockAddr
+    { cdAddr :: Either (Local SockAddr)  -- Peer connection local address
+                       (Remote SockAddr) -- Client connection remote address
     , cdType :: ConnectionType
     }
     deriving (Eq,Ord,Show)
 
+addrToPeerKey :: Remote SockAddr -> PeerAddress
+addrToPeerKey (Remote raddr) = PeerAddress raddr
+
+addrFromClientKey :: ClientAddress -> Local SockAddr
+addrFromClientKey (ClientAddress laddr) = Local laddr
+
+classifyConnection :: SockAddr -> ConnectionData -> Either (PeerAddress, Local SockAddr)
+                                                           (ClientAddress, Remote SockAddr)
+classifyConnection saddr dta = case cdAddr dta of
+    Left  laddr -> Left  (PeerAddress saddr, laddr)
+    Right raddr -> Right (ClientAddress saddr, raddr)
+
 data XMPPServer
     = forall releaseKey.
-      XMPPServer { _xmpp_sv :: Server ConnectionKey ConnectionData releaseKey XML.Event
-                 , _xmpp_peer_params :: ConnectionParameters ConnectionKey ConnectionData
+      XMPPServer { _xmpp_sv :: Server SockAddr ConnectionData releaseKey XML.Event
+                 , _xmpp_peer_params :: ConnectionParameters SockAddr ConnectionData
                  }
 
-grokPeer :: XMPPServer -> ConnectionKey -> (SockAddr, ConnectionParameters ConnectionKey ConnectionData, Miliseconds)
-grokPeer sv (PeerKey addr) = (addr, _xmpp_peer_params sv, 10000)
+grokPeer :: XMPPServer -> SockAddr -> (SockAddr, ConnectionParameters SockAddr ConnectionData, Miliseconds)
+grokPeer sv addr = (addr, _xmpp_peer_params sv, 10000)
+
 
 xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text)
-xmppConnections xsv@XMPPServer{_xmpp_sv=sv} = tcpManager (grokPeer xsv) (Just . Text.pack) resolvPeer sv
+xmppConnections xsv@XMPPServer{_xmpp_sv=sv} = tcpManager (grokPeer xsv) (Just . Text.pack) resolve sv
  where
-    resolvPeer :: Text -> IO (Maybe ConnectionKey)
-    resolvPeer str = fmap PeerKey <$> listToMaybe <$> resolvePeer str
+    resolve :: Text -> IO (Maybe SockAddr)
+    resolve hostname = listToMaybe . map (\(PeerAddress addr) -> addr) <$> resolvePeer hostname
 
-xmppEventChannel :: XMPPServer -> TChan ((ConnectionKey, ConnectionData), ConnectionEvent Event)
+xmppEventChannel :: XMPPServer -> TChan ((SockAddr, ConnectionData), ConnectionEvent Event)
 xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
 
 quitXmpp :: XMPPServer -> IO ()