1 files changed, 41 insertions, 4 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 8f13e2d8..69b6cec5 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -28,12 +28,17 @@ import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,E
 import System.Posix.User (getUserEntryForID,userName)
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified ConfigFiles
+import Data.Maybe (listToMaybe)
 
 import UTmp (ProcessID,users)
 import LocalPeerCred
 import XMPPServer
 -- import Server
 
+unsplitJID (n,h,r) = jid
+ where
+    jid0 = maybe h (\n->n<>"@"<>h) n
+    jid = maybe jid0 (\r->jid0<>"/"<>r) r
 
 splitJID :: Text -> (Maybe Text,Text,Maybe Text)
 splitJID bjid = 
@@ -68,6 +73,7 @@ data PresenceState = PresenceState
     { clients :: TVar (Map ConnectionKey ClientState)
     , associatedPeers :: TVar (Map SockAddr ())
     , server :: TMVar XMPPServer
+    , writeTos :: TVar (Map ConnectionKey (TChan Stanza))
     }
 
 
@@ -83,7 +89,7 @@ resolvePeer addrtext = do
 
 
 getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
-getConsolePids state = do --  return [("tty7", 23)] -- todo
+getConsolePids state = do
     us <- UTmp.users
     return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
 
@@ -168,15 +174,44 @@ rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
 rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
 rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 
+newConn state k outchan =
+    atomically $ modifyTVar' (writeTos state) $ Map.insert k outchan
+
+eofConn state k = atomically $ modifyTVar' (writeTos state) $ Map.delete k
+
+rewriteJIDForPeer :: Text -> IO (Maybe (Text,SockAddr))
+rewriteJIDForPeer jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- fmap listToMaybe $ resolvePeer h
+    return $ flip fmap maddr $ \addr ->
+        let h' = addrToText addr
+            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
 
 main = runResourceT $ do
     state <- liftIO . atomically $ do
         clients <- newTVar Map.empty
         associatedPeers <- newTVar Map.empty
         xmpp <- newEmptyTMVar
+        writeTos <- newTVar Map.empty
         return PresenceState
             { clients = clients
             , associatedPeers = associatedPeers
+            , writeTos = writeTos
             , server = xmpp
             }
     sv <- xmppServer
@@ -187,20 +222,22 @@ main = runResourceT $ do
         , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
         , xmppTellPeerHisName = return . peerKeyToText
         , xmppTellClientNameOfPeer = peerKeyToResolvedName
-        , xmppNewConnection = \k outchan -> return ()
-        , xmppEOF = \k -> return ()
+        , xmppNewConnection = newConn state
+        , xmppEOF = eofConn state
         , xmppRosterBuddies = rosterGetBuddies state
         , xmppRosterSubscribers = rosterGetSubscribers state
         , xmppRosterSolicited = rosterGetSolicited state
         , xmppRosterOthers = rosterGetOthers state
         , xmppSubscribeToRoster = \k -> return ()
         -- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
-        , xmppDeliverMessage = \fail msg -> do
+        , {- xmppDeliverMessage = \fail msg -> do
             let msgs = msgLangMap (stanzaType msg)
                 body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs
             when (not $ null body) $ do
             Text.putStrLn $ "MESSAGE " <> head body
             return ()
+          -}
+          xmppDeliverMessage = deliverMessage state
         , xmppInformClientPresence = \k stanza -> return ()
         }
     liftIO $ do