deliver message from client to remote peer.

2 files changed, 89 insertions, 12 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index af986645..eb680002 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -14,6 +14,7 @@ module XMPPServer
     , peerKeyToText
     , peerKeyToResolvedName
     , addrToText
+    , sendModifiedStanzaToPeer
     ) where
 import Debug.Trace
 import Control.Monad.Trans.Resource (runResourceT)
@@ -245,6 +246,38 @@ prettyPrint prefix =
         =$= CB.lines 
         =$ CL.mapM_ (wlogb . (prefix <>))
 
+swapNamespace old new = awaitForever swapit
+ where
+    swapit (EventBeginElement n as) | nameNamespace n==Just old =
+        yield $ EventBeginElement (n { nameNamespace = Just new }) as
+    swapit (EventEndElement n) | nameNamespace n==Just old =
+        yield $ EventEndElement (n { nameNamespace = Just new })
+    swapit x = yield x
+
+fixHeaders Stanza { stanzaTo=mto, stanzaFrom=mfrom } = do
+    x <- await
+    maybe (return ()) f x
+ where
+    f (EventBeginElement n as) = do yield $ EventBeginElement n (update as)
+                                    awaitForever yield
+    f x = yield x >> awaitForever yield
+    update as = as''
+     where
+        as' = maybe as (\to->attr "to" to:as) mto
+        as'' = maybe as' (\from->attr "from" from:as') mfrom
+    
+
+sendModifiedStanzaToPeer 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:client" "jabber:server" =$= fixHeaders stanza
+
 -- id,to, and from are taken as-is from reply list
 sendReply donevar stype reply replychan = do
     if null reply then return ()
@@ -802,6 +835,15 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
                              else [] )
                 yield $ EventEndElement "{jabber:iq:roster}item"
 
+conduitToChan c = do
+    chan <- atomically newTChan
+    clsrs <- atomically $ newTVar (Just [])
+    quitvar <- atomically $ newEmptyTMVar
+    forkIO $ do
+        c =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
+        atomically $ writeTVar clsrs Nothing
+    return (chan,clsrs,quitvar)
+
 sendRoster query xmpp replyto = do
     let k = case stanzaOrigin query of
              NetworkOrigin k _ -> Just k
@@ -834,12 +876,7 @@ sendRoster query xmpp replyto = do
             xmlifyRosterItems solicited "none" subnone
             yield $ EventEndElement "{jabber:iq:roster}query"
             yield $ EventEndElement "{jabber:client}iq"
-    chan <- atomically newTChan
-    clsrs <- atomically $ newTVar (Just [])
-    quitvar <- atomically $ newEmptyTMVar
-    forkIO $ do
-        roster =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
-        atomically $ writeTVar clsrs Nothing
+    (chan,clsrs,quitvar) <- conduitToChan roster
     ioWriteChan replyto
         Stanza  { stanzaType = Roster
                 , stanzaId = (stanzaId query)
@@ -904,7 +941,8 @@ monitor sv params xmpp = do
                             sendRoster stanza xmpp replyto
                             xmppSubscribeToRoster xmpp k
                         Message {} -> do
-                            let fail = return () -- todo
+                            let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
+                            stanza2 <- atomically $ cloneStanza stanza
                             xmppDeliverMessage xmpp fail stanza
                         PresenceStatus {} -> do
                             xmppInformClientPresence xmpp k stanza
@@ -914,13 +952,15 @@ monitor sv params xmpp = do
                             sendReply quitVar Error reply replyto
                         _ -> return ()
                 _ -> return ()
+        -- We need to clone in the case the stanza is passed on as for Message.
+        dup <- atomically $ cloneStanza stanza
         let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
             c = case stanzaOrigin stanza of
                     LocalPeer -> "*"
                     NetworkOrigin (ClientKey {}) _ -> "C"
                     NetworkOrigin (PeerKey {})   _ -> "P"
         wlog ""
-        stanzaToConduit stanza $$ prettyPrint typ
+        stanzaToConduit dup $$ prettyPrint typ
         
       ]
     action
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