From d4c8249985f2aa4895a9eb844a357a885c87c749 Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 18 Feb 2014 01:05:41 -0500 Subject: end to end messaging --- Presence/XMPPServer.hs | 65 +++++++++++++++++++++------ xmppServer.hs | 119 +++++++++++++++++++++++++++++++++++++++++-------- 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 -- cgit v1.2.3