From 24bd9dfb9e8e908056ce2bb601b6fe16bfa84c7a Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 30 Jun 2013 14:20:43 -0400 Subject: outgoing connections to peers added to XMPP.hs. It still uses Handle for now, TODO: change to a ByteString sink. --- Presence/XMPP.hs | 198 ++++++++++++++++++++++++++++++++++++++++++++++++- Presence/XMPPServer.hs | 63 ---------------- Presence/XMPPTypes.hs | 86 ++++++++++++++++++++- 3 files changed, 279 insertions(+), 68 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 1a4b0e7b..417b3ce7 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -16,8 +16,29 @@ import SocketLike import ByteStringOperators import Data.HList -import Network.Socket (Family) -import Network.BSD (PortNumber) +import Network.Socket + ( Family + , connect + , socketToHandle + , sClose + , Socket(..) + , socket + , SocketType(..) + ) +import Network.BSD + ( PortNumber + , getHostName + , hostName + , hostAliases + , getProtocolNumber + ) +import System.IO + ( BufferMode(..) + , IOMode(..) + , hSetBuffering + ) +import Control.Exception + ( bracketOnError ) import Control.Concurrent.STM import Data.Conduit import qualified Data.Conduit.List as CL @@ -27,6 +48,8 @@ import qualified Data.ByteString.Char8 as S (pack,putStr,putStrLn,append) import qualified Data.ByteString.Lazy.Char8 as L ( putStrLn , fromChunks + , unlines + , hPutStrLn ) import Control.Concurrent (forkIO,killThread) import Control.Concurrent.Async @@ -39,7 +62,6 @@ import Control.Monad as Monad import Text.XML.Stream.Parse (parseBytes,content) import Text.XML.Stream.Render import Data.XML.Types as XML -import Network.BSD (getHostName,hostName,hostAliases) import Data.Text.Encoding as S (decodeUtf8,encodeUtf8) import Data.Text.Lazy.Encoding as L (decodeUtf8,encodeUtf8) import Data.Text.Lazy (toStrict) @@ -54,6 +76,11 @@ import Data.List (find) import qualified Text.Show.ByteString as L import NestingXML import qualified Data.Set as Set +import qualified Data.Map as Map +import GHC.Conc + ( threadStatus + , ThreadStatus(..) + ) data Commands = Send [XML.Event] | QuitThread deriving Prelude.Show @@ -534,9 +561,174 @@ fromPeer session = doNestingXML $ do +{- seekRemotePeers :: XMPPConfig config => config -> TChan Presence -> IO () seekRemotePeers config chan = do putStrLn "unimplemented: seekRemotePeers" -- TODO return () +-} + +data OutBoundMessage = OutBoundPresence Presence + deriving Prelude.Show + +newServerConnections = atomically $ newTVar Map.empty + +connect_to_server chan peer = (>> return ()) . runMaybeT $ do + let port = 5269 :: Int + + connected <- liftIO . async $ connect' (peerAddr peer) port + + -- We'll cache Presence notifications until the socket + -- is ready. + cached <- liftIO $ newIORef Map.empty + + sock <- MaybeT . fix $ \loop -> do + e <- atomically $ orElse + (fmap Right $ waitSTM connected) + (fmap Left $ readTChan chan) + case e of + Left (OutBoundPresence (Presence jid Offline)) -> do + cached_map <- readIORef cached + writeIORef cached (Map.delete jid cached_map) + loop + Left (OutBoundPresence p@(Presence jid st)) -> do + cached_map <- readIORef cached + writeIORef cached (Map.insert jid st cached_map) + loop + {- + Left event -> do + L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event + loop + -} + Right sock -> return sock + + liftIO $ do + h <- socketToHandle sock ReadWriteMode + hSetBuffering h NoBuffering + L.hPutStrLn h "" + L.putStrLn $ "OUT peer: " + cache <- fmap Map.assocs . readIORef $ cached + writeIORef cached Map.empty -- hint garbage collector: we're done with this + forM_ cache $ \(jid,st) -> do + r <- xmlifyPresenceForPeer sock (Presence jid st) + L.hPutStrLn h r + L.putStrLn $ "OUT peer: (cache)\n" <++> r <++> "\n" + fix $ \loop -> do + event <- atomically $ readTChan chan + case event of + OutBoundPresence p -> do + r <- xmlifyPresenceForPeer sock p + L.hPutStrLn h r + L.putStrLn $ "OUT peer:\n" <++> r <++> "\n" + loop + L.hPutStrLn h "" + L.putStrLn $ "OUT peer: " + +connect' :: SockAddr -> Int -> IO (Maybe Socket) +connect' addr port = 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 withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a + withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum 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` port) + where + tryToConnect proto addr = + bracketOnError + (socket (socketFamily addr) Stream proto) + (sClose ) -- only done if there's an error + (\sock -> do + connect sock addr + return (Just sock) -- socketToHandle sock ReadWriteMode + ) + + + +sendMessage cons msg peer = do + found <- atomically $ do + consmap <- readTVar cons + return (Map.lookup peer consmap) + let newEntry = do + chan <- atomically newTChan + t <- forkIO $ connect_to_server chan 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: " <++> showPeer peer + return (False,(chan,t)) + died = do + -- L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer + newEntry + case st of + ThreadRunning -> running + ThreadBlocked _ -> running + ThreadDied -> died + ThreadFinished -> died + ) + found + -- L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg + atomically $ writeTChan (fst entry) msg + when is_new . atomically $ + readTVar cons >>= writeTVar cons . Map.insert peer entry + + + +seekRemotePeers :: XMPPConfig config => + config -> TChan Presence -> IO b0 +seekRemotePeers config chan = do + server_connections <- newServerConnections + fix $ \loop -> do + event <- atomically $ readTChan chan + case event of + p@(Presence jid stat) | not (is_remote (peer jid)) -> do + -- L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat + runMaybeT $ do + u <- MaybeT . return $ name jid + subscribers <- liftIO $ do + subs <- getSubscribers config u + mapM parseHostNameJID subs + -- liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers + let peers = Set.map peer (Set.fromList subscribers) + forM_ (Set.toList peers) $ \peer -> do + when (is_remote peer) $ + liftIO $ sendMessage server_connections (OutBoundPresence p) peer + -- TODO: send presence probes for buddies + -- TODO: cache remote presences for clients + _ -> return (Just ()) + loop + +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? diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index f607989d..ff50ab1c 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -67,9 +67,6 @@ import qualified Data.Set as Set import GetHostByAddr import XMPPTypes -is_remote (RemotePeer _) = True -is_remote _ = False - getNamesForPeer :: Peer -> IO [ByteString] getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName getNamesForPeer peer@(RemotePeer addr) = do @@ -85,10 +82,6 @@ getNamesForPeer peer@(RemotePeer addr) = do return . map pack $ names -peerAddr :: Peer -> SockAddr -peerAddr (RemotePeer addr) = addr --- peerAddr LocalHost = throw exception - xmlifyPresenceForPeer sock (Presence jid stat) = do -- TODO: accept socket argument and determine local ip address @@ -587,62 +580,6 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do L.putStrLn $ "OUT peer: " -splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString) -splitJID bjid = - let xs = L.splitWith (=='@') bjid - ys = L.splitWith (=='/') (last xs) - server = head ys - name - = case xs of - (n:s:_) -> Just n - (s:_) -> Nothing - rsrc = case ys of - (s:_:_) -> Just $ last ys - _ -> Nothing - 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 -> Int -> IO (Maybe Socket) connect' addr port = do proto <- getProtocolNumber "tcp" diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs index e3bbfd16..8af1018c 100644 --- a/Presence/XMPPTypes.hs +++ b/Presence/XMPPTypes.hs @@ -2,10 +2,28 @@ {-# LANGUAGE TypeFamilies #-} module XMPPTypes where -import Network.Socket (Socket,SockAddr(..)) +import Network.Socket + ( Socket + , Family(..) + , SockAddr(..) + , getAddrInfo + , addrCanonName + , addrAddress + , defaultHints + , AddrInfo(..) + , AddrInfoFlag(..) + ) +import Network.BSD (getHostName) import System.IO (Handle) import Control.Concurrent.STM (TChan) -import Data.ByteString.Lazy.Char8 as L (ByteString,unpack,pack) +import Data.ByteString.Lazy.Char8 as L + ( ByteString + , unpack + , pack + , splitWith + , uncons + , takeWhile + ) import Text.Show.ByteString as L import Data.Binary.Builder as B import Data.Binary.Put @@ -82,4 +100,68 @@ showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude. where (pre,bracket) = break (==']') s +is_remote (RemotePeer _) = True +is_remote _ = False + +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 + +splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString) +splitJID bjid = + let xs = L.splitWith (=='@') bjid + ys = L.splitWith (=='/') (last xs) + server = head ys + name + = case xs of + (n:s:_) -> Just n + (s:_) -> Nothing + rsrc = case ys of + (s:_:_) -> Just $ last ys + _ -> Nothing + 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 + +peerAddr :: Peer -> SockAddr +peerAddr (RemotePeer addr) = addr +-- peerAddr LocalHost = throw exception + +socketFamily (SockAddrInet _ _) = AF_INET +socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +socketFamily (SockAddrUnix _) = AF_UNIX + -- cgit v1.2.3 From 2136b30a030a6e8ed56ff2487a4d6fc860d3a10b Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 30 Jun 2013 14:23:47 -0400 Subject: SocketC now exports packetSink --- Presence/ServerC.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Presence/ServerC.hs b/Presence/ServerC.hs index b16a0099..22104a31 100644 --- a/Presence/ServerC.hs +++ b/Presence/ServerC.hs @@ -8,6 +8,7 @@ module ServerC , ServerHandle , quitListening , dummyServerHandle + , packetSink ) where import Network.Socket as Socket @@ -123,13 +124,13 @@ packets h = do where getPacket h = do { hWaitForInput h (-1) ; hGetNonBlocking h 1024 } -outgoing :: MonadIO m => Handle -> Sink S.ByteString m () -outgoing h = do +packetSink :: MonadIO m => Handle -> Sink S.ByteString m () +packetSink h = do -- liftIO . L.putStrLn $ "outgoing: waiting" mpacket <- await -- liftIO . L.putStrLn $ "outgoing: got packet " <++> bshow mpacket maybe (return ()) - (\r -> (liftIO . S.hPutStrLn h $ r) >> outgoing h) + (\r -> (liftIO . S.hPutStrLn h $ r) >> packetSink h) mpacket @@ -148,5 +149,5 @@ runConn g st (sock,_) = do h <- socketToHandle sock ReadWriteMode hSetBuffering h NoBuffering let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n") - handle doException (g (restrictSocket sock `HCons` st) (packets h) (outgoing h)) + handle doException (g (restrictSocket sock `HCons` st) (packets h) (packetSink h)) hClose h -- cgit v1.2.3 From b2b10356bea2887fa7f2430cf119114e711cce2c Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 30 Jun 2013 15:58:23 -0400 Subject: regarding outbound-to-peer connections: changed from socket Handle to a ByteString sink. --- Presence/XMPP.hs | 90 +++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 63 insertions(+), 27 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 417b3ce7..70f2905a 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -103,11 +103,11 @@ xmlifyPresenceForClient (Presence jid stat) = do return (concatMap presenceEvents jidstrs) where presenceEvents jidstr = - [ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat) - , EventBeginElement "show" [] + [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat) + , EventBeginElement "{jabber:client}show" [] , EventContent (ContentText . shw $ stat) - , EventEndElement "show" - , EventEndElement "presence" + , EventEndElement "{jabber:client}show" + , EventEndElement "{jabber:client}presence" ] typ Offline = [("type",[ContentText "unavailable"])] typ _ = [] @@ -607,24 +607,56 @@ connect_to_server chan peer = (>> return ()) . runMaybeT $ do liftIO $ do h <- socketToHandle sock ReadWriteMode hSetBuffering h NoBuffering - L.hPutStrLn h "" - L.putStrLn $ "OUT peer: " + let snk = packetSink h cache <- fmap Map.assocs . readIORef $ cached writeIORef cached Map.empty -- hint garbage collector: we're done with this - forM_ cache $ \(jid,st) -> do - r <- xmlifyPresenceForPeer sock (Presence jid st) - L.hPutStrLn h r - L.putStrLn $ "OUT peer: (cache)\n" <++> r <++> "\n" - fix $ \loop -> do - event <- atomically $ readTChan chan - case event of - OutBoundPresence p -> do - r <- xmlifyPresenceForPeer sock p - L.hPutStrLn h r - L.putStrLn $ "OUT peer:\n" <++> r <++> "\n" - loop - L.hPutStrLn h "" - L.putStrLn $ "OUT peer: " + handleOutgoingToPeer (restrictSocket sock) cache chan snk + + +greetPeer = + [ EventBeginDocument + , EventBeginElement (streamP "stream") + [("xmlns",[ContentText "jabber:server"]) + ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"]) + ,("version",[ContentText "1.0"]) + ] + ] + +goodbyePeer = + [ EventEndElement "{jabber:server}stream" + , EventEndDocument + ] + +toPeer sock cache chan = do + let log = liftIO . L.putStrLn . ("(>P) " <++>) + yield greetPeer + log "" + forM_ cache $ \(jid,st) -> do + r <- lift $ xmlifyPresenceForPeer sock (Presence jid st) + yield r + log $ "(cache) \n" <++> bshow r + fix $ \loop -> do + event <- lift . atomically $ readTChan chan + case event of + OutBoundPresence p -> do + r <- lift $ xmlifyPresenceForPeer sock p + yield r + log (bshow r) + loop + yield goodbyePeer + log "" + +handleOutgoingToPeer sock cache chan snk = do +#ifdef RENDERFLUSH + toPeer sock cache chan + $$ flushList + =$= renderBuilderFlush def + =$= builderToByteStringFlush + =$= discardFlush + =$ snk +#else + toPeer sock cache chan $$ renderChunks =$ snk +#endif connect' :: SockAddr -> Int -> IO (Maybe Socket) connect' addr port = do @@ -720,15 +752,19 @@ xmlifyPresenceForPeer sock (Presence jid stat) = do addr <- getSocketName sock let n = name jid rsc = resource jid - jid_str = n <$++> "@" showPeer (RemotePeer addr) <++?> "/" <++$> rsc - return . L.unlines $ - [ " typ stat <++> ">" - , "" <++> shw stat <++> "" - , "" + jidstr = toStrict . L.decodeUtf8 + $ n <$++> "@" showPeer (RemotePeer addr) <++?> "/" <++$> rsc + return + [ EventBeginElement "{jabber:server}presence" + (("from",[ContentText jidstr]):typ stat) + , EventBeginElement "{jabber:server}show" [] + , EventContent (ContentText . shw $ stat) + , EventEndElement "{jabber:server}show" + , EventEndElement "{jabber:server}presence" ] where - typ Offline = " type='unavailable'" - typ _ = "" + typ Offline = [("type",[ContentText "unavailable"])] + typ _ = [] shw Available = "chat" shw Away = "away" shw Offline = "away" -- Is this right? -- cgit v1.2.3 From b4429d84f016a41e9cb7d012c128d80fdc2c05af Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 30 Jun 2013 16:52:45 -0400 Subject: handle presence announcements between peers --- Presence/XMPP.hs | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 66 insertions(+), 2 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 70f2905a..4c8beec4 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -75,6 +75,7 @@ import Data.Conduit.Blaze import Data.List (find) import qualified Text.Show.ByteString as L import NestingXML +import Data.Set as Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map import GHC.Conc @@ -528,7 +529,7 @@ handlePeer st src snk = do jids <- newTVarIO Set.empty session <- newSession session_factory sock - finally ( src $= parseBytes def $$ fromPeer session ) + finally ( src $= parseBytes def $$ fromPeer (session,jids) ) $ do L.putStrLn $ "(P) disconnected " <++> name js <- fmap Set.toList (readTVarIO jids) @@ -536,8 +537,61 @@ handlePeer st src snk = do forM_ js $ announcePresence session . offline closeSession session + +handlePeerPresence (session,jids) stanza False = do + -- Offline + withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do + peer_jid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid]) + liftIO . atomically $ do + jids_ <- readTVar jids + writeTVar jids (Set.delete peer_jid jids_) + liftIO $ announcePresence session (Presence peer_jid Offline) +handlePeerPresence (session,jids) stanza True = do + -- online (Available or Away) + let log = liftIO . L.putStrLn . ("(P) " <++>) + withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do + pjid <- liftIO $ parseAddressJID (L.fromChunks [S.encodeUtf8 jid]) + -- stat <- show element content + let parseChildren stat = do + child <- nextElement + case child of + Just tag | tagName tag=="{jabber:server}show" + -> fmap toStat (lift content) + Just tag | otherwise -> parseChildren stat + Nothing -> return stat + toStat "away" = Away + toStat "xa" = Away -- TODO: xa + toStat "dnd" = Away -- TODO: dnd + toStat "chat" = Available + + stat' <- parseChildren Available + + liftIO . atomically $ do + jids_ <- readTVar jids + writeTVar jids (Set.insert pjid jids_) + liftIO $ announcePresence session (Presence pjid stat') + log $ bshow (Presence pjid stat') + +matchAttribMaybe name (Just value) attrs = + case find ( (==name) . fst) attrs of + Just (_,[ContentText x]) | x==value -> True + Just (_,[ContentEntity x]) | x==value -> True + _ -> False +matchAttribMaybe name Nothing attrs + | find ( (==name) . fst) attrs==Nothing + = True + +presenceTypeOffline = Just "unavailable" +presenceTypeOnline = Nothing + +isPresence (EventBeginElement name attrs) testType + | name=="{jabber:server}presence" + && matchAttribMaybe "type" testType attrs + = True +isPresenceOf _ _ = False + fromPeer :: (MonadThrow m,MonadIO m, XMPPSession session) => - session -> Sink XML.Event m () + (session, TVar (Set JID)) -> Sink XML.Event m () fromPeer session = doNestingXML $ do let log = liftIO . L.putStrLn . ("(P) " <++>) withXML $ \begindoc -> do @@ -552,6 +606,16 @@ fromPeer session = doNestingXML $ do whenJust nextElement $ \stanza -> do stanza_lvl <- nesting + let unhandledStanza = do + mb <- lift . runMaybeT $ gatherElement stanza Seq.empty + withJust mb $ \xs -> prettyPrint "P: " (toList xs) + case () of + _ | stanza `isPresenceOf` presenceTypeOnline + -> handlePeerPresence session stanza True + _ | stanza `isPresenceOf` presenceTypeOffline + -> handlePeerPresence session stanza False + _ -> unhandledStanza + awaitCloser stanza_lvl loop -- cgit v1.2.3 From 332002c101682f9c796a973cf62a82bef2c4659e Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 30 Jun 2013 18:11:17 -0400 Subject: bug fixes --- Presence/XMPP.hs | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 4c8beec4..36630bc7 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -130,8 +130,8 @@ greet host = ,("version",[ContentText "1.0"]) ] , EventBeginElement (streamP "features") [] - , EventBeginElement "bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])] - , EventEndElement "bind" + , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" [] + , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" {- -- , " " @@ -149,6 +149,7 @@ greet host = mawait :: Monad m => MaybeT (ConduitM i o m) i mawait = MaybeT await +-- Note: This function ignores name space qualification elementAttrs expected (EventBeginElement name attrs) | nameLocalName name==expected = return attrs @@ -437,15 +438,16 @@ prettyPrint prefix xs = toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event] toClient pchan cmdChan = fix $ \loop -> do + let send xs = yield xs >> prettyPrint ">C: " xs event <- liftIO . atomically $ orElse (fmap Left $ readTChan pchan) (fmap Right $ readTChan cmdChan) case event of Right QuitThread -> return () - Right (Send xs) -> yield xs >> prettyPrint ">C: " xs >> loop + Right (Send xs) -> send xs >> loop Left presence -> do xs <- liftIO $ xmlifyPresenceForClient presence - yield xs + send xs loop handleClient @@ -580,11 +582,14 @@ matchAttribMaybe name (Just value) attrs = matchAttribMaybe name Nothing attrs | find ( (==name) . fst) attrs==Nothing = True +matchAttribMaybe name Nothing attrs + | otherwise + = False presenceTypeOffline = Just "unavailable" presenceTypeOnline = Nothing -isPresence (EventBeginElement name attrs) testType +isPresenceOf (EventBeginElement name attrs) testType | name=="{jabber:server}presence" && matchAttribMaybe "type" testType attrs = True @@ -611,7 +616,7 @@ fromPeer session = doNestingXML $ do withJust mb $ \xs -> prettyPrint "P: " (toList xs) case () of _ | stanza `isPresenceOf` presenceTypeOnline - -> handlePeerPresence session stanza True + -> log "peer online!" >> handlePeerPresence session stanza True _ | stanza `isPresenceOf` presenceTypeOffline -> handlePeerPresence session stanza False _ -> unhandledStanza @@ -681,34 +686,30 @@ greetPeer = [ EventBeginDocument , EventBeginElement (streamP "stream") [("xmlns",[ContentText "jabber:server"]) - ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"]) ,("version",[ContentText "1.0"]) ] ] goodbyePeer = - [ EventEndElement "{jabber:server}stream" + [ EventEndElement (streamP "stream") , EventEndDocument ] toPeer sock cache chan = do - let log = liftIO . L.putStrLn . ("(>P) " <++>) - yield greetPeer - log "" + let -- log = liftIO . L.putStrLn . ("(>P) " <++>) + send xs = yield xs >> prettyPrint ">P: " xs + send greetPeer forM_ cache $ \(jid,st) -> do r <- lift $ xmlifyPresenceForPeer sock (Presence jid st) - yield r - log $ "(cache) \n" <++> bshow r + send r fix $ \loop -> do event <- lift . atomically $ readTChan chan case event of OutBoundPresence p -> do r <- lift $ xmlifyPresenceForPeer sock p - yield r - log (bshow r) + send r loop - yield goodbyePeer - log "" + send goodbyePeer handleOutgoingToPeer sock cache chan snk = do #ifdef RENDERFLUSH -- cgit v1.2.3