deliver message from client to remote peer.

1 files changed, 48 insertions, 8 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