1 files changed, 100 insertions, 19 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 69b6cec5..7b352b8a 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -10,7 +10,7 @@ import Network.Socket
     , getAddrInfo
     , defaultHints
     , addrFlags
-    , AddrInfoFlag(AI_CANONNAME,AI_V4MAPPED)
+    , AddrInfoFlag(AI_CANONNAME,AI_V4MAPPED,AI_NUMERICHOST)
     , SockAddr(..)
     )
 import System.Endian (fromBE32)
@@ -71,9 +71,10 @@ data ClientState = ClientState
 
 data PresenceState = PresenceState
     { clients :: TVar (Map ConnectionKey ClientState)
+    , clientsByUser :: TVar (Map Text (ConnectionKey,ClientState)) -- TODO: should be list
     , associatedPeers :: TVar (Map SockAddr ())
     , server :: TMVar XMPPServer
-    , writeTos :: TVar (Map ConnectionKey (TChan Stanza))
+    , writeTos :: TVar (Map ConnectionKey Conn)
     }
 
 
@@ -84,9 +85,14 @@ resolvePeer :: Text -> IO [SockAddr]
 resolvePeer addrtext = do
         fmap (map $ make6mapped4 . addrAddress) $ 
             getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
-                    (Just $ Text.unpack addrtext)
+                    (Just $ Text.unpack $ strip_brackets addrtext)
                     (Just "5269")
 
+strip_brackets s = 
+    case Text.uncons s of
+      Just ('[',t) -> Text.takeWhile (/=']') t
+      _            -> s
+
 
 getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
 getConsolePids state = do
@@ -109,8 +115,10 @@ chooseResourceName state k addr desired = do
                              , clientUser = user
                              , clientPid = pid }
 
-    atomically $
+    atomically $ do
         modifyTVar' (clients state) $ Map.insert k client
+        modifyTVar' (clientsByUser state) $ Map.insert (clientUser client) (k,client)
+
     localJID (clientUser client) (clientResource client)
     
   where
@@ -174,11 +182,58 @@ rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
 rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
 rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 
-newConn state k outchan =
-    atomically $ modifyTVar' (writeTos state) $ Map.insert k outchan
+data Conn = Conn { connChan :: TChan Stanza
+                 , auxAddr :: SockAddr }
+
+newConn state k addr outchan =
+    atomically $ modifyTVar' (writeTos state)
+        $ Map.insert k Conn { connChan = outchan
+                            , auxAddr  = addr }
 
 eofConn state k = atomically $ modifyTVar' (writeTos state) $ Map.delete k
 
+rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr))
+rewriteJIDForClient1 jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- fmap listToMaybe $ resolvePeer h
+    flip (maybe $ return Nothing) maddr $ \addr -> do
+        h' <- peerKeyToResolvedName (PeerKey addr)
+        return $ Just ((n,h',r), addr)
+
+parseAddress :: Text -> IO (Maybe SockAddr)
+parseAddress addr_str = do
+    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) 
+                        (Just . Text.unpack $ addr_str) 
+                        (Just "0")
+    return . listToMaybe $ map addrAddress info
+
+todo = error "Unimplemented"
+
+
+-- | for example:  2001-db8-85a3-8d3-1319-8a2e-370-7348.ipv6-literal.net
+ip6literal :: Text -> Text
+ip6literal addr = Text.map dash addr <> ".ipv6-literal.net"
+ where
+    dash ':' = '-'
+    dash x   = x
+
+withPort (SockAddrInet _ a)      port = SockAddrInet (toEnum port) a
+withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
+
+-- | The given address is taken to be the local address for the socket this JID
+-- came in on.  The returned JID parts are suitable for unsplitJID to create a
+-- valid JID for communicating to a client.  The returned Bool is True when the
+-- host part refers to this local host (i.e. it equals the given SockAddr).
+rewriteJIDForClient :: SockAddr -> Text -> IO (Bool,(Maybe Text,Text,Maybe Text))
+rewriteJIDForClient laddr jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- parseAddress (strip_brackets h)
+    flip (maybe $ return (False,(n,ip6literal h,r))) maddr $ \addr -> do
+    let mine =  laddr `withPort` 0  == addr `withPort` 0
+    h' <- if mine then textHostName
+                  else peerKeyToResolvedName (PeerKey addr)
+    return (mine,(n,h',r))
+
 rewriteJIDForPeer :: Text -> IO (Maybe (Text,SockAddr))
 rewriteJIDForPeer jid = do
     let (n,h,r) = splitJID jid
@@ -188,28 +243,54 @@ rewriteJIDForPeer jid = do
             to' = unsplitJID (n,h',r)
         in (to',addr)
 
-deliverMessage state fail msg = do
-    mto <- do
-        flip (maybe $ return Nothing) (stanzaTo msg) $ \to -> do
-        rewriteJIDForPeer to
-    flip (maybe fail) mto $ \(to',addr) -> do
-    from' <- do
-        flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
-        m <- rewriteJIDForPeer from
-        return $ fmap fst m
-    let k = PeerKey addr
-    chans <- atomically $ readTVar (writeTos state)
-    flip (maybe fail) (Map.lookup k chans) $ \chan -> do
-    sendModifiedStanzaToPeer (msg { stanzaTo=Just to', stanzaFrom=from' }) chan
+deliverMessage state fail msg = 
+    case stanzaOrigin msg of
+      NetworkOrigin senderk@(ClientKey {}) _ -> do
+        mto <- do
+            flip (maybe $ return Nothing) (stanzaTo msg) $ \to -> do
+            rewriteJIDForPeer to
+        flip (maybe fail) mto $ \(to',addr) -> do
+        let k = PeerKey addr
+        chans <- atomically $ readTVar (writeTos state)
+        flip (maybe fail) (Map.lookup k chans) $ \(Conn { connChan=chan
+                                                        , auxAddr=laddr }) -> do
+        (n,r) <- forClient state senderk (return (Nothing,Nothing))
+                        $ \c -> return (Just (clientUser c), Just (clientResource c))
+        -- original 'from' address is discarded.
+        let from' = unsplitJID (n,addrToText laddr,r)
+        sendModifiedStanzaToPeer (msg { stanzaTo=Just to', stanzaFrom=Just from' }) chan
+      NetworkOrigin senderk@(PeerKey {}) _ -> do
+        chans <- atomically $ readTVar (writeTos state)
+        flip (maybe fail) (Map.lookup senderk chans)
+            $ \(Conn { connChan=sender_chan
+                     , auxAddr=laddr }) -> do
+        flip (maybe fail) (stanzaTo msg) $ \to -> do
+        (mine,(n,h,r)) <- rewriteJIDForClient laddr to
+        if not mine then fail else do
+        let to' = unsplitJID (n,h,r)
+        from' <- do
+            flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
+            (_,trip) <- rewriteJIDForClient laddr from
+            return . Just $ unsplitJID trip
+        cmap <- atomically . readTVar $ clientsByUser state
+        flip (maybe fail) n $ \n -> do
+        flip (maybe fail) (Map.lookup n cmap) $ \(k,_) -> do
+        flip (maybe fail) (Map.lookup k chans) $ \Conn { connChan=chan} -> do
+        sendModifiedStanzaToClient (msg { stanzaTo=Just to'
+                                        , stanzaFrom=from' })
+                                   chan
+
 
 main = runResourceT $ do
     state <- liftIO . atomically $ do
         clients <- newTVar Map.empty
+        clientsByUser <- newTVar Map.empty
         associatedPeers <- newTVar Map.empty
         xmpp <- newEmptyTMVar
         writeTos <- newTVar Map.empty
         return PresenceState
             { clients = clients
+            , clientsByUser = clientsByUser
             , associatedPeers = associatedPeers
             , writeTos = writeTos
             , server = xmpp