cloneTChan unavailable in wheezy :(

added reverse-lookups for peer names

1 files changed, 40 insertions, 4 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index aab689ad..c0bede90 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module XMPPServer
     ( xmppServer
@@ -11,6 +12,7 @@ module XMPPServer
     , cloneStanza
     , LangSpecificMessage(..)
     , peerKeyToText
+    , peerKeyToResolvedName
     , addrToText
     ) where
 import Debug.Trace
@@ -39,7 +41,7 @@ import Data.Conduit.Blaze (builderToByteStringFlush)
 import qualified Text.XML.Stream.Render as XML
 import qualified Text.XML.Stream.Parse as XML
 import Data.XML.Types as XML
-import Data.Maybe (catMaybes,fromJust,isJust,isNothing)
+import Data.Maybe (catMaybes,fromJust,isJust,isNothing,listToMaybe)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack,unpack)
@@ -49,7 +51,9 @@ import qualified Data.Map as Map
 import Data.Set (Set, (\\) )
 import qualified Data.Set as Set
 import qualified System.Random 
+import qualified Network.BSD as BSD
 
+import GetHostByAddr (getHostByAddr)
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
 import ControlMaybe
 import Nesting
@@ -150,7 +154,7 @@ data XMPPServerParameters =
     , xmppRosterOthers       :: ConnectionKey -> IO [Text]
     , xmppSubscribeToRoster :: ConnectionKey -> IO ()
     -- , xmppLookupClientJID :: ConnectionKey -> IO Text
-    , xmppLookupPeerName  :: ConnectionKey -> IO Text
+    , xmppTellClientNameOfPeer :: ConnectionKey -> IO Text
     , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
     , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
     }
@@ -171,7 +175,16 @@ addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
 
 peerKeyToText :: ConnectionKey -> Text
 peerKeyToText (PeerKey { callBackAddress=addr }) = addrToText addr
-peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt"
+peerKeyToText (ClientKey { localAddress=addr }) = "ErrorClIeNt0"
+
+peerKeyToResolvedName :: ConnectionKey -> IO Text
+peerKeyToResolvedName k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
+peerKeyToResolvedName k@(PeerKey { callBackAddress=addr }) = do
+    ent <- getHostByAddr addr --  AF_UNSPEC addr
+    let names = BSD.hostName ent : BSD.hostAliases ent
+        mname = listToMaybe names
+    return $ maybe (peerKeyToText k) Text.pack mname 
+
 
 wlog s = putStrLn s
  where _ = s :: String
@@ -796,7 +809,7 @@ sendRoster query xmpp replyto = do
     flip (maybe $ return ()) k $ \k -> do
     jid <- case k of
                 ClientKey {} -> xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
-                PeerKey {}   -> xmppLookupPeerName xmpp k
+                PeerKey {}   -> xmppTellClientNameOfPeer xmpp k
     let getlist f = do
             bs <- f xmpp k
             -- js <- mapM parseHostNameJID bs
@@ -936,6 +949,7 @@ xmppServer xmpp = do
         gen <- System.Random.getStdGen
         let (r,gen') = System.Random.next gen
         return $ r `mod` 2000 -- maximum 2 seconds of fuzz
+    liftIO . wlog $ "pingfuzz = " ++ show pingfuzz
     let peer_params = (connectionDefaults peerKey)
                           { pingInterval = 15000 + pingfuzz
                           , timeout = 2000
@@ -949,3 +963,25 @@ xmppServer xmpp = do
         control sv (Listen peerport peer_params)
         control sv (Listen clientport client_params)
     return XMPPServer { _xmpp_sv = sv, _xmpp_peer_params = peer_params }
+
+#if MIN_VERSION_stm(2,4,0)
+#else
+-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
+-- same content available as the original channel.
+--
+-- Terrible inefficient implementation provided to build against older libraries.
+cloneTChan :: TChan a -> STM (TChan a)
+cloneTChan chan = do
+    contents <- chanContents' chan
+    chan2 <- dupTChan chan
+    mapM_ (writeTChan chan) contents
+    mapM_ (writeTChan chan2) contents
+    return chan2
+ where
+    chanContents' chan = do
+        b <- isEmptyTChan chan
+        if b then return [] else do
+        x <- readTChan chan
+        xs <- chanContents' chan
+        return (x:xs)
+#endif