From e74b4448748af7e068a9d162b62fccc0ede0e81a Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 25 Jun 2013 18:09:08 -0400 Subject: SEnd addresses on the wire between peers rather than domain names. --- Presence/LocalPeerCred.hs | 31 ++++--- Presence/Server.hs | 12 ++- Presence/XMPPServer.hs | 222 ++++++++++++++++++++++++++++++++++++++-------- Presence/main.hs | 7 +- 4 files changed, 216 insertions(+), 56 deletions(-) diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs index b544af97..ee1a4a0f 100644 --- a/Presence/LocalPeerCred.hs +++ b/Presence/LocalPeerCred.hs @@ -1,5 +1,11 @@ module LocalPeerCred where +{- for main +import System.Environment +import Control.Monad +-} + +import System.Endian import Data.ByteString.Lazy.Char8 as L hiding (map,putStrLn,tail,splitAt,tails,filter) import qualified Data.ByteString.Lazy.Char8 as L (splitAt) import qualified Data.ByteString.Lazy as W8 @@ -38,7 +44,9 @@ getLocalPeerCred' (SockAddrInet portn host) = do getLocalPeerCred' (SockAddrInet6 portn flow host scope) = do let port = fromEnum portn - trace "tcp6" $ withFile "/proc/net/tcp6" ReadMode (parseProcNet port host) + (a,b,c,d) = host + host' = (toBE32 a, toBE32 b, toBE32 c, toBE32 d) + withFile "/proc/net/tcp6" ReadMode (parseProcNet port host') getLocalPeerCred' addr@(SockAddrUnix _) = -- TODO: parse /proc/net/unix @@ -81,20 +89,21 @@ parseProcNet port host h = do fmap snd . listToMaybe $ filter ((==(port,host)).fst) rs {- trace ("found: "++show u) -} u `seq` return u -{- + {- where a === b = let r= a==b in trace ("Comparing "++show (a,b)++"-->"++show r) r --} + -} {- main = do args <- getArgs - let addr = fromJust $ do - port <- args ?? 0 - host <- args ?? 1 - return $ SockAddrInet (toEnum . fromIntegral . readInt $ port) (toEnum (read host::Int)) - readInt x = read x :: Int - - r <- getLocalPeerCred' addr - putStrLn $ "r = " ++ show r + let addr_str = fromJust (args??0) + port_str = fromJust (args??1) + info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) + (Just addr_str) + (Just port_str) + let addrs = map addrAddress info + forM_ addrs $ \addr -> do + r <- getLocalPeerCred' addr + putStrLn $ "r{"++show addr++"} = " ++ show r -} diff --git a/Presence/Server.hs b/Presence/Server.hs index 369bd538..a9bd4112 100644 --- a/Presence/Server.hs +++ b/Presence/Server.hs @@ -59,7 +59,11 @@ doServer -> IO l) -> IO Socket -} -doServer port g startCon = runServer2 port (runConn2 g) +doServer port g startCon = do + -- doServer' AF_INET port g startCon + doServer' AF_INET6 port g startCon + +doServer' family port g startCon = runServer2 port (runConn2 g) where runConn2 g st (sock,_) = do h <- socketToHandle sock ReadWriteMode @@ -80,9 +84,11 @@ doServer port g startCon = runServer2 port (runConn2 g) PortNumber -> (num -> (Socket, SockAddr) -> IO b -> IO b) -> IO b -} runServer2 st@(HCons port _) go = do - sock <- socket AF_INET Stream 0 + sock <- socket family Stream 0 setSocketOption sock ReuseAddr 1 - bindSocket sock (SockAddrInet port iNADDR_ANY) + case family of + AF_INET -> bindSocket sock (SockAddrInet port iNADDR_ANY) + AF_INET6 -> bindSocket sock (SockAddrInet6 port 0 iN6ADDR_ANY 8) listen sock 2 forkIO $ do mainLoop sock (ConnId 0) go diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 387b223e..aa3140e5 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -21,6 +21,9 @@ import Data.ByteString.Lazy.Char8 as L ( hPutStrLn , unlines , lines + , uncons + , takeWhile + , concat , splitWith , drop , ByteString @@ -57,19 +60,69 @@ import Data.Binary.Builder as B import Data.Binary.Put import qualified Data.Map as Map import GHC.Conc -import Network.BSD +import Network.BSD hiding (getHostByAddr) import Control.Concurrent.Async import qualified Data.Set as Set +import GetHostByAddr + +data Peer = LocalHost | RemotePeer SockAddr + deriving (Eq,Prelude.Show) + +instance Ord Peer where + LocalHost <= _ + = True + RemotePeer (SockAddrUnix a) <= RemotePeer (SockAddrUnix b) + = a <= b + RemotePeer (SockAddrUnix _) <= _ + = True + RemotePeer (SockAddrInet aport a) <= RemotePeer (SockAddrInet bport b) + = (a,aport) <= (b,bport) + RemotePeer (SockAddrInet aport a) <= _ + = True + RemotePeer (SockAddrInet6 aport aflow a ascope) <= RemotePeer (SockAddrInet6 bport bflow b bscope) + = (a,aport,ascope,aflow) <= (b,bport,bscope,bflow) + a <= b = False -- | Jabber ID (JID) datatype data JID = JID { name :: Maybe ByteString - , server :: ByteString + , peer :: Peer , resource :: Maybe ByteString } - deriving (Ord,Eq) + deriving (Eq,Ord) + +is_remote (RemotePeer _) = True +is_remote _ = False + +getNamesForPeer :: Peer -> IO [ByteString] +getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName +getNamesForPeer peer@(RemotePeer addr) = do + {- + let hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] } + L.putStrLn $ "getAddrInfo 1 " <++> showPeer peer + infos <- getAddrInfo hints (Just . unpack . showPeer $ peer) Nothing + return . map pack . mapMaybe addrCanonName $ infos + -} + -- ent <- getHostByName (unpack . showPeer $ peer) + ent <- getHostByAddr addr -- AF_UNSPEC addr + let names = hostName ent : hostAliases ent + return . map pack $ names + + +showPeer :: Peer -> ByteString +showPeer LocalHost = "localhost" +showPeer (RemotePeer addr@(SockAddrInet _ _)) = pack $ stripColon (Prelude.show addr) + where stripColon s = pre where (pre,port) = break (==':') s +showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.show addr) + where stripColon s = if null bracket then pre else pre ++ "]" + where + (pre,bracket) = break (==']') s + +peerAddr :: Peer -> SockAddr +peerAddr (RemotePeer addr) = addr +-- peerAddr LocalHost = throw exception instance L.Show JID where - showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" s <++?> "/" <++$> r + showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" showPeer s <++?> "/" <++$> r instance Prelude.Show JID where show jid = L.unpack $ L.show jid @@ -87,12 +140,38 @@ data JabberShow = Offline data Presence = Presence JID JabberShow deriving Prelude.Show -xmlifyPresence (Presence jid stat) = L.unlines - [ " typ stat <++> ">" - , "" <++> shw stat <++> "" - , "" - ] +xmlifyPresenceForPeer sock (Presence jid stat) = do + -- TODO: accept socket argument and determine local ip address + -- connected to this peer. + addr <- getSocketName sock + let n = name jid + rsc = resource jid + jid_str = n <$++> "@" showPeer (RemotePeer addr) <++?> "/" <++$> rsc + return . L.unlines $ + [ " typ stat <++> ">" + , "" <++> shw stat <++> "" + , "" + ] + where + typ Offline = " type='unavailable'" + typ _ = "" + shw Available = "chat" + shw Away = "away" + shw Offline = "away" -- Is this right? + +xmlifyPresenceForClient (Presence jid stat) = do + let n = name jid + rsc = resource jid + names <- getNamesForPeer (peer jid) + let tostr p = n <$++> "@" p <++?> "/" <++$> rsc + jidstrs = fmap tostr names + return (L.concat $ map doit jidstrs) where + doit jidstr = L.unlines + [ " typ stat <++> ">" + , "" <++> shw stat <++> "" + , "" + ] typ Offline = " type='unavailable'" typ _ = "" shw Available = "chat" @@ -160,7 +239,7 @@ startCon session_factory sock st = do L.putStrLn $ "PRESENCE: " <++> bshow presence -- TODO: it violates spec to send presence information before -- a resource is bound. - let r = xmlifyPresence presence + r <- xmlifyPresenceForClient presence hPutStrLn h r L.putStrLn $ "\nOUT:\n" <++> r Right (Send r) -> @@ -282,7 +361,11 @@ doCon st elem cont = do atomically $ writeTChan cmdChan (Send r) -- hPutStrLn h r L.putStrLn $ "\nOUT:\n" <++> r - host <- fmap server $ getJID session + -- host <- fmap pack $ getHostName -- Assume localhost for client session JID + host <- do + jid <- getJID session + names <- getNamesForPeer (peer jid) + return (head names) putStrLn $ (Prelude.show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n" @@ -369,16 +452,18 @@ doPeer st elem cont = do case (jid,typ) of (Just jid,Just "unavailable") -> do L.putStrLn $ "INBOUND PRESENCE! Offline jid=" <++> jid - announcePresence session (Presence (parseJID jid) Offline) + -- parseAddressJID -- convert peer reported user@address to JID data structure + peer_jid <- parseAddressJID jid + announcePresence session (Presence peer_jid Offline) (Just jid,Just typ) -> -- possible probe, ignored for now L.putStrLn $ "INBOUND PRESENCE! "<++>typ<++>" jid="<++>jid (Just jid,Nothing) -> do let string (CString _ s _) = [s] - show = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content - + stat = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content -- Available or Away. - L.putStrLn $ "INBOUND PRESENCE! avail/away jid=" <++> jid + names <- parseAddressJID jid >>= getNamesForPeer . peer + L.putStrLn $ "INBOUND PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid -- todo: announcePresence _ -> return () -- putStrLn $ "inbound unhandled: "++show v cont () @@ -426,16 +511,16 @@ sendMessage cons msg peer = do let newEntry = do chan <- atomically newTChan t <- forkIO $ connect_to_server chan peer - L.putStrLn $ "remote-map new: " <++> peer + L.putStrLn $ "remote-map new: " <++> showPeer peer return (True,(chan,t)) (is_new,entry) <- maybe newEntry ( \(chan,t) -> do st <- threadStatus t let running = do - L.putStrLn $ "remote-map, thread running: " <++> peer + L.putStrLn $ "remote-map, thread running: " <++> showPeer peer return (False,(chan,t)) died = do - L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> peer + L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer newEntry case st of ThreadRunning -> running @@ -444,7 +529,7 @@ sendMessage cons msg peer = do ThreadFinished -> died ) found - L.putStrLn $ "sendMessage ->"<++>peer<++>": "<++>bshow msg + L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg atomically $ writeTChan (fst entry) msg when is_new . atomically $ readTVar cons >>= writeTVar cons . Map.insert peer entry @@ -452,7 +537,7 @@ sendMessage cons msg peer = do connect_to_server chan peer = (>> return ()) . runMaybeT $ do let port = "5269" - connected <- liftIO . async $ connect' (unpack peer) port + connected <- liftIO . async $ connect' (peerAddr peer) port -- We'll cache Presence notifications until the socket -- is ready. @@ -486,14 +571,14 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do cache <- fmap Map.assocs . readIORef $ cached writeIORef cached Map.empty -- hint garbage collector: we're done with this forM_ cache $ \(jid,st) -> do - let r = xmlifyPresence (Presence jid st) + r <- xmlifyPresenceForPeer sock (Presence jid st) hPutStrLn h r L.putStrLn $ "REMOTE-OUT (cache):\n" <++> r <++> "\n" fix $ \loop -> do event <- atomically $ readTChan chan case event of OutBoundPresence p -> do - let r = xmlifyPresence p + r <- xmlifyPresenceForPeer sock p hPutStrLn h r L.putStrLn $ "REMOTE-OUT:\n" <++> r <++> "\n" loop @@ -501,34 +586,90 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do L.putStrLn $ "REMOTE-OUT: " -parseJID :: ByteString -> JID -parseJID bjid = +splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString) +splitJID bjid = let xs = L.splitWith (=='@') bjid ys = L.splitWith (=='/') (last xs) - (name,server) + server = head ys + name = case xs of - (n:s:_) -> (Just n,s) - (s:_) -> (Nothing,s) + (n:s:_) -> Just n + (s:_) -> Nothing rsrc = case ys of (s:_:_) -> Just $ last ys _ -> Nothing - in JID name server rsrc - -connect' :: HostName -> ServiceName -> IO (Maybe Socket) -connect' host serv = do + in (name,server,rsrc) + +strip_brackets s = + case L.uncons s of + Just ('[',t) -> L.takeWhile (/=']') t + _ -> s + +parseAddressJID :: ByteString -> IO JID +parseAddressJID jid = do + let (name,peer_string,rsc) = splitJID jid + hints = Just $ defaultHints { addrFlags = [ {- AI_NUMERICHOST, -} AI_CANONNAME ] } + peer_string' = unpack . strip_brackets $ peer_string + peer <- do + putStrLn $ "getAddrInfo 2 " ++ Prelude.show ( Just (unpack peer_string)) + info <- getAddrInfo hints (Just peer_string') Nothing -- (Just "xmpp-server") + let info0 = head info + return . RemotePeer . addrAddress $ info0 + return $ JID name peer rsc + +parseHostNameJID :: ByteString -> IO JID +parseHostNameJID jid = do + let (name,peer_string,rsc) = splitJID jid + hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] } + peer <- do + if peer_string=="localhost" + then return LocalHost + else do + putStrLn $ "getAddrInfo 3 " ++ Prelude.show ( Just (unpack peer_string)) + info <- getAddrInfo hints (Just (unpack peer_string)) Nothing -- (Just "xmpp-server") + let info0 = head info + cname = addrCanonName info0 + if cname==Just "localhost" + then return LocalHost + else do + self <- getHostName + return $ if Just self==cname + then LocalHost + else RemotePeer (addrAddress info0) + return $ JID name peer rsc + +socketFamily (SockAddrInet _ _) = AF_INET +socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +socketFamily (SockAddrUnix _) = AF_UNIX + +connect' :: SockAddr -> ServiceName -> IO (Maybe Socket) +connect' addr serv = do proto <- getProtocolNumber "tcp" + {- + -- Given (host :: HostName) ... let hints = defaultHints { addrFlags = [AI_ADDRCONFIG] , addrProtocol = proto , addrSocketType = Stream } addrs <- getAddrInfo (Just hints) (Just host) (Just serv) firstSuccessful $ map tryToConnect addrs + -} + let getport (SockAddrInet port _) = port + getport (SockAddrInet6 port _ _ _) = port + let port = getport addr + let withPort (SockAddrInet _ a) port = SockAddrInet port a + withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 port a b c + let doException (SomeException e) = do + L.putStrLn $ "\nFailed to reach "<++> showPeer (RemotePeer addr) <++> " on port "<++>bshow port<++>": " <++> bshow e + return Nothing + handle doException + $ tryToConnect proto (addr `withPort` 5269) where - tryToConnect addr = + tryToConnect proto addr = bracketOnError - (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (socket (socketFamily addr) Stream proto) (sClose ) -- only done if there's an error (\sock -> do - connect sock (addrAddress addr) + connect sock addr return (Just sock) -- socketToHandle sock ReadWriteMode ) @@ -547,8 +688,8 @@ firstSuccessful (p:ps) = catchIO p $ \e -> seekRemotePeers :: XMPPConfig config => - (ByteString -> Bool) -> config -> TChan Presence -> IO b0 -seekRemotePeers is_peer config chan = do + config -> TChan Presence -> IO b0 +seekRemotePeers config chan = do server_connections <- newServerConnections fix $ \loop -> do event <- atomically $ readTChan chan @@ -557,10 +698,13 @@ seekRemotePeers is_peer config chan = do L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat runMaybeT $ do u <- MaybeT . return $ name jid - subscribers <- liftIO $ getSubscribers config u + subscribers <- liftIO $ do + subs <- getSubscribers config u + mapM parseHostNameJID subs liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers - let peers = Set.map (server . parseJID) (Set.fromList subscribers) + -- parseJID -- get subscriber list reported user@hostname to JID data structure + let peers = Set.map peer (Set.fromList subscribers) forM_ (Set.toList peers) $ \peer -> do - when (is_peer peer) $ + when (is_remote peer) $ liftIO $ sendMessage server_connections (OutBoundPresence p) peer loop diff --git a/Presence/main.hs b/Presence/main.hs index ed247bca..24d240cd 100644 --- a/Presence/main.hs +++ b/Presence/main.hs @@ -52,7 +52,7 @@ import qualified Text.Show.ByteString as L data UnixSession = UnixSession { - localhost :: ByteString, + localhost :: Peer, -- ByteString, unix_uid :: (IORef (Maybe UserID)), unix_resource :: (IORef (Maybe L.ByteString)), presence_state :: PresenceState @@ -145,7 +145,7 @@ update_presence locals_greedy subscribers state getStatus = type RefCount = Int data PresenceState = PresenceState - { hostname :: ByteString + { hostname :: Peer -- ByteString , currentTTY :: TVar ByteString , activeUsers :: TVar (Set JID) , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) @@ -200,12 +200,13 @@ instance XMPPConfig UnixConfig where start :: ByteString -> IO () start host = do + let host = LocalHost tracked <- newPresenceState host let dologin e = track_login host tracked e dologin :: t -> IO () chan <- atomically $ subscribeToChan (localSubscriber tracked) - remotes <- forkIO $ seekRemotePeers (/=host) UnixConfig chan + remotes <- forkIO $ seekRemotePeers UnixConfig chan installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing -- cgit v1.2.3