2 files changed, 151 insertions, 33 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index eb680002..631f97c3 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -15,6 +15,7 @@ module XMPPServer
     , peerKeyToResolvedName
     , addrToText
     , sendModifiedStanzaToPeer
+    , sendModifiedStanzaToClient
     ) where
 import Debug.Trace
 import Control.Monad.Trans.Resource (runResourceT)
@@ -147,7 +148,7 @@ data XMPPServerParameters =
     , xmppTellMyNameToPeer :: SockAddr -> IO Text
     , xmppTellClientHisName :: ConnectionKey -> IO Text
     , xmppTellPeerHisName :: ConnectionKey -> IO Text
-    , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO ()
+    , xmppNewConnection :: ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
     , xmppEOF :: ConnectionKey -> IO ()
     , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
     , xmppRosterSubscribers  :: ConnectionKey -> IO [Text]
@@ -181,9 +182,10 @@ 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
+    mname <- handleIO_ (return Nothing) $ do
+        ent <- getHostByAddr addr --  AF_UNSPEC addr
+        let names = BSD.hostName ent : BSD.hostAliases ent
+        return $ listToMaybe names
     return $ maybe (peerKeyToText k) Text.pack mname 
 
 
@@ -278,6 +280,17 @@ sendModifiedStanzaToPeer stanza chan = do
  where
     c = stanzaToConduit stanza =$= swapNamespace "jabber:client" "jabber:server" =$= fixHeaders stanza
 
+sendModifiedStanzaToClient stanza chan = do
+    (echan,clsrs,quitvar) <- conduitToChan c
+    ioWriteChan chan
+        stanza  { stanzaChan = echan
+                , stanzaClosers = clsrs
+                , stanzaInterrupt = quitvar
+                -- TODO id? origin?
+                }
+ where
+    c = stanzaToConduit stanza =$= swapNamespace "jabber:server" "jabber:client" =$= fixHeaders stanza
+
 -- id,to, and from are taken as-is from reply list
 sendReply donevar stype reply replychan = do
     if null reply then return ()
@@ -532,6 +545,7 @@ xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $
                     pongfrom = maybe me id mto
                     pong = makePong namespace mid pongto pongfrom
                 sendReply donevar Pong pong output
+#ifdef PINGNOISE
                 -- TODO: Remove this, it is only to generate a debug print
                 ioWriteChan stanzas Stanza
                             { stanzaType = Ping
@@ -543,6 +557,7 @@ xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $
                             , stanzaInterrupt = donevar
                             , stanzaOrigin = NetworkOrigin k output
                             }
+#endif
               stype -> ioWriteChan stanzas Stanza
                             { stanzaType = stype
                             , stanzaId = mid
@@ -745,10 +760,20 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
                 [readTChan output >>= \stanza -> return $ do
-                    dup <- atomically $ cloneStanza stanza
-                    stanzaToConduit dup $$ prettyPrint $ case k of
-                        ClientKey {} -> "C<-" <> bshow (stanzaType dup) <> " "
-                        PeerKey {}   -> "P<-" <> bshow (stanzaType dup) <> " "
+#ifndef PINGNOISE
+                    let notping f = case stanzaType stanza of Pong -> return ()
+                                                              _ -> f
+#else
+                    let notping f = f
+#endif
+                    notping $ do
+                        dup <- atomically $ cloneStanza stanza
+                        let typ = Strict8.pack $ c ++ "<-"++(concat . take 1 . words $ show (stanzaType dup))++" "
+                            c = case k of
+                                    ClientKey {} -> "C"
+                                    PeerKey {}   -> "P"
+                        wlog ""
+                        stanzaToConduit dup $$ prettyPrint typ
                     stanzaToConduit stanza
                         $$ awaitForever
                             $ liftIO . atomically . Slotted.push slots Nothing
@@ -762,10 +787,12 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
                         ping = makePing namespace mid to from
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
                           ping
+#ifdef PINGNOISE
                     wlog ""
                     CL.sourceList ping $$ prettyPrint $ case k of
                         ClientKey {} -> "C<-Ping"
                         PeerKey {} -> "P<-Ping "
+#endif
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
@@ -912,7 +939,7 @@ monitor sv params xmpp = do
                  wlog $ tomsg k "Connection"
                  let (xsrc,xsnk) = xmlStream conread conwrite
                  outs <- forkConnection sv xmpp k u pingflag xsrc xsnk stanzas
-                 xmppNewConnection xmpp k outs
+                 xmppNewConnection xmpp k u outs
                  return ()
             ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
             EOF        -> do wlog $ tomsg k "EOF"
@@ -924,7 +951,17 @@ monitor sv params xmpp = do
             RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
+        dup <- case stanzaType stanza of
+                Message {} -> do
+                    dup <- atomically $ cloneStanza stanza -- dupped so we can make debug print
+                    return dup
+                _ -> return stanza
         forkIO $ do
+            case stanzaType stanza of
+                Message {} -> do
+                    let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
+                    xmppDeliverMessage xmpp fail stanza
+                _ -> return ()
             case stanzaOrigin stanza of
                 NetworkOrigin k@(ClientKey {}) replyto -> 
                     case stanzaType stanza of
@@ -940,10 +977,6 @@ monitor sv params xmpp = do
                         RequestRoster -> do
                             sendRoster stanza xmpp replyto
                             xmppSubscribeToRoster xmpp k
-                        Message {} -> do
-                            let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
-                            stanza2 <- atomically $ cloneStanza stanza
-                            xmppDeliverMessage xmpp fail stanza
                         PresenceStatus {} -> do
                             xmppInformClientPresence xmpp k stanza
                         UnrecognizedQuery query -> do
@@ -953,7 +986,11 @@ monitor sv params xmpp = do
                         _ -> return ()
                 _ -> return ()
         -- We need to clone in the case the stanza is passed on as for Message.
-        dup <- atomically $ cloneStanza stanza
+#ifndef PINGNOISE
+        let notping f = case stanzaType stanza of Pong -> return ()
+                                                  _ -> f
+        notping $ do
+#endif
         let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
             c = case stanzaOrigin stanza of
                     LocalPeer -> "*"
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