Updated XMPPServer to use SockAddr user data for Server

1 files changed, 22 insertions, 13 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 83a9fb39..222d8ac4 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -121,7 +121,7 @@ data Stanza = Stanza
 
 data XMPPServerParameters =
     XMPPServerParameters
-    { xmppChooseResourceName :: ConnectionKey -> Socket -> Maybe Text -> IO Text
+    { xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> IO Text
     , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO ()
     , xmppEOF :: ConnectionKey -> IO ()
     , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
@@ -396,7 +396,7 @@ grokStanza "jabber:client" stanzaTag =
                 _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
                 _ -> return $ Just Unrecognized
 
-xmppInbound :: Server ConnectionKey
+xmppInbound :: Server ConnectionKey SockAddr
                 -> ConnectionKey
                 -> FlagCommand 
                 -> Source IO XML.Event
@@ -617,7 +617,7 @@ goodbye =
     , EventEndDocument
     ]
 
-forkConnection :: Server ConnectionKey
+forkConnection :: Server ConnectionKey SockAddr
                 -> ConnectionKey
                 -> FlagCommand
                 -> Source IO XML.Event
@@ -710,9 +710,12 @@ peerKey (sock,addr) = do
       sIsConnected sock >>= \c -> 
         if c then getPeerName sock -- addr is normally socketName
              else return addr      -- Weird hack: addr is would-be peer name
-    return $ PeerKey (peer `withPort` fromIntegral peerport)
+    laddr <- getSocketName sock
+    return $ (PeerKey (peer `withPort` fromIntegral peerport),laddr)
 
-clientKey (sock,addr) = return $ ClientKey addr
+clientKey (sock,addr) = do
+    laddr <- getSocketName sock
+    return $ (ClientKey addr,laddr)
 
 stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
 stanzaToConduit stanza = do
@@ -797,11 +800,17 @@ sendRoster query xmpp replyto = do
                 , stanzaOrigin = LocalPeer
                 }
 
-socketFromKey :: Server k -> k -> IO Socket
+socketFromKey :: Server ConnectionKey SockAddr -> ConnectionKey -> IO SockAddr
 socketFromKey sv k = do
-    let v = Map.lookup k $ conmap sv
-    flip (maybe $ todo) v $ \_ ->do
-    return todo
+    map <- atomically $ readTVar (conmap sv)
+    let mcd = Map.lookup k map
+    case mcd of
+        Nothing -> case k of
+                    ClientKey addr -> return addr
+                    PeerKey addr -> return addr 
+                        -- XXX: ? wrong address
+                        -- Shouldnt happen anyway.
+        Just cd -> return $ cdata cd
 
 monitor sv params xmpp = do
     chan <- return $ serverEvent sv
@@ -809,7 +818,7 @@ monitor sv params xmpp = do
     quitVar <- atomically newEmptyTMVar
     fix $ \loop -> do
     action <- atomically $ foldr1 orElse
-      [ readTChan chan >>= \(k,e) -> return $ do 
+      [ readTChan chan >>= \((k,u),e) -> return $ do 
         case e of
             Connection pingflag conread conwrite -> do
                  wlog $ tomsg k "Connection"
@@ -832,8 +841,8 @@ monitor sv params xmpp = do
                 NetworkOrigin k@(ClientKey {}) replyto -> 
                     case stanzaType stanza of
                         RequestResource wanted -> do
-                            sock <- socketFromKey sv k
-                            rsc <- xmppChooseResourceName xmpp k sock wanted
+                            sockaddr <- socketFromKey sv k
+                            rsc <- xmppChooseResourceName xmpp k sockaddr wanted
                             let reply = iq_bind_reply (stanzaId stanza) rsc
                             sendReply quitVar SetResource reply replyto
                         SessionRequest -> do
@@ -870,7 +879,7 @@ monitor sv params xmpp = do
 
 xmppServer :: ( MonadResource m
               , MonadIO m
-              ) => XMPPServerParameters -> m (Server ConnectionKey,ConnectionParameters ConnectionKey)
+              ) => XMPPServerParameters -> m (Server ConnectionKey SockAddr,ConnectionParameters ConnectionKey SockAddr)
 xmppServer xmpp = do
     sv <- server
     -- some fuzz helps avoid simultaneity