cloneTChan unavailable in wheezy :(

added reverse-lookups for peer names

1 files changed, 8 insertions, 6 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index ec3a618d..80adaf21 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -9,6 +9,7 @@ import Network.Socket
     , defaultHints
     , addrFlags
     , AddrInfoFlag(AI_CANONNAME)
+    , SockAddr
     )
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
@@ -43,6 +44,7 @@ data ClientState = ClientState
 
 data PresenceState = PresenceState
     { clients :: TVar (Map ConnectionKey ClientState)
+    , associatedPeers :: TVar (Map SockAddr ())
     }
 
 getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
@@ -104,13 +106,13 @@ tellClientHisName state k = forClient state k fallback go
 
 
 main = runResourceT $ do
-    -- us <- liftIO UTmp.users
-    -- liftIO $ putStrLn (show us)
-    hostname <- liftIO textHostName
-    state <- do
-        clients <- liftIO . atomically $ newTVar Map.empty
+    -- hostname <- liftIO textHostName
+    state <- liftIO . atomically $ do
+        clients <- newTVar Map.empty
+        associatedPeers <- newTVar Map.empty
         return PresenceState
             { clients = clients
+            , associatedPeers = associatedPeers
             }
     sv <- xmppServer
         XMPPServerParameters
@@ -119,6 +121,7 @@ main = runResourceT $ do
         , xmppTellMyNameToClient = textHostName
         , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
         , xmppTellPeerHisName = return . peerKeyToText
+        , xmppTellClientNameOfPeer = peerKeyToResolvedName
         , xmppNewConnection = \k outchan -> return ()
         , xmppEOF = \k -> return ()
         , xmppRosterBuddies = \k -> return []
@@ -126,7 +129,6 @@ main = runResourceT $ do
         , xmppRosterSolicited = \k -> return []
         , xmppRosterOthers = \k -> return []
         , xmppSubscribeToRoster = \k -> return ()
-        , xmppLookupPeerName = \k ->  return "localhost"
         -- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
         , xmppDeliverMessage = \fail msg -> do
             let msgs = msgLangMap (stanzaType msg)