From e34385a64f8d0ec431023001c9619994601df0a9 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 17 Feb 2014 20:17:32 -0500 Subject: deliver message from client to remote peer. --- Presence/XMPPServer.hs | 56 ++++++++++++++++++++++++++++++++++++++++++-------- xmppServer.hs | 45 ++++++++++++++++++++++++++++++++++++---- 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 -- cgit v1.2.3