From 9d01ddf6dabc1fdd1a40d7f79b7d21d3e2c6baf1 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 15 Feb 2014 22:37:11 -0500 Subject: Answer client bind-resource request. Quieted connect-fail messages. --- Presence/Server.hs | 26 +++++------ Presence/XMPPServer.hs | 120 +++++++++++++++++++++++++++++++++++-------------- 2 files changed, 100 insertions(+), 46 deletions(-) (limited to 'Presence') diff --git a/Presence/Server.hs b/Presence/Server.hs index a1c4923b..baf5a1a8 100644 --- a/Presence/Server.hs +++ b/Presence/Server.hs @@ -42,7 +42,7 @@ import Control.Monad.Fix -- import Control.Monad.STM import Control.Monad.Trans.Resource import Control.Monad.IO.Class (MonadIO (liftIO)) -import System.IO.Error (ioeGetErrorType) +import System.IO.Error (ioeGetErrorType,isDoesNotExistError) import System.IO ( IOMode(..) , hSetBuffering @@ -311,18 +311,17 @@ server = do where forkit = void . forkIO $ do proto <- getProtocolNumber "tcp" - sock <- bracketOnError - (socket (socketFamily addr) Stream proto) - (\sock -> do -- only done if there's an error - -- Weird hack: puting the would-be peer address - -- instead of local socketName + sock <- socket (socketFamily addr) Stream proto + handle (\e -> do -- let t = ioeGetErrorType e + when (isDoesNotExistError e) $ return () -- warn "GOTCHA" + -- warn $ "connect-error: " <> bshow e conkey <- makeConnKey params (sock,addr) -- XXX: ? sClose sock atomically $ writeTChan (serverEvent server) $ (conkey,ConnectFailure addr)) - $ \sock -> do connect sock addr - return sock + $ do + connect sock addr me <- getSocketName sock conkey <- makeConnKey params (sock,me) h <- socketToHandle sock ReadWriteMode @@ -350,9 +349,10 @@ server = do fix $ \retryLoop -> do utc <- getCurrentTime forkIO $ do - sock <- bracketOnError - (socket (socketFamily addr) Stream proto) - (\sock -> do -- only done if there's an error + sock <- socket (socketFamily addr) Stream proto + handle (\e -> do -- let t = ioeGetErrorType e + when (isDoesNotExistError e) $ return () -- warn "GOTCHA" + -- warn $ "connect-error: " <> bshow e -- Weird hack: puting the would-be peer address -- instead of local socketName conkey <- makeConnKey params (sock,addr) -- XXX: ? @@ -362,8 +362,8 @@ server = do $ (conkey,ConnectFailure addr) retry <- readTVar retryVar putTMVar resultVar retry) - $ \sock -> do connect sock addr - return sock + $ do + connect sock addr me <- getSocketName sock conkey <- makeConnKey params (sock,me) h <- socketToHandle sock ReadWriteMode diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 8afc3245..ceb83476 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -37,6 +37,7 @@ import ControlMaybe import Nesting import EventUtil import Server +import ResourcePolicy (getResourceName) peerport = 5269 clientport = 5222 @@ -101,10 +102,10 @@ data Stanza stanzaChan :: TChan (Maybe XML.Event) } -} -data StanzaType = Unrecognized | Ping | Pong | BindResource (Maybe Text) +data StanzaType = Unrecognized | Ping | Pong | RequestResource (Maybe Text) | SetResource deriving Show -data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey +data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza) data Stanza = Stanza { stanzaType :: StanzaType @@ -141,6 +142,31 @@ prettyPrint prefix = =$= CB.lines =$ CL.mapM_ (wlogb . (prefix <>)) +sendReply donevar stype reply replychan = do + if null reply then return () + else do + let stanzaTag = head reply + mid = lookupAttrib "id" (tagAttrs stanzaTag) + mfrom = lookupAttrib "from" (tagAttrs stanzaTag) + mto = lookupAttrib "to" (tagAttrs stanzaTag) + replyStanza <- liftIO . atomically $ do + replyChan <- newTChan + replyClsrs <- newTVar (Just []) + return Stanza { stanzaType = stype + , stanzaId = mid + , stanzaTo = mto -- todo: should this be reversed? + , stanzaFrom = mfrom -- todo: should this be reversed? + , stanzaChan = replyChan + , stanzaClosers = replyClsrs + , stanzaInterrupt = donevar + , stanzaOrigin = LocalPeer + } + ioWriteChan replychan replyStanza + void . liftIO . forkIO $ do + mapM_ (ioWriteChan $ stanzaChan replyStanza) reply + liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing + -- liftIO $ wlog "finished reply stanza" + grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType) grokStanzaIQGet stanza = do mtag <- nextElement @@ -166,9 +192,9 @@ grokStanzaIQSet stanza = do case fmap tagName mchild of Just "{urn:ietf:params:xml:ns:xmpp-bind}resource" -> do rsc <- XML.content -- TODO: MonadThrow??? - return . Just $ BindResource (Just rsc) + return . Just $ RequestResource (Just rsc) Just _ -> return Nothing - Nothing -> return . Just $ BindResource Nothing + Nothing -> return . Just $ RequestResource Nothing _ -> return Nothing @@ -227,35 +253,31 @@ xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do mfrom = lookupAttrib "from" (tagAttrs stanzaTag) mto = lookupAttrib "to" (tagAttrs stanzaTag) dispatch <- grokStanza namespace stanzaTag - flip (maybe $ return ()) dispatch $ \dispatch -> + let unrecog = do + let stype = Unrecognized + s <- liftIO . atomically $ do + return Stanza + { stanzaType = stype + , stanzaId = mid + , stanzaTo = mto + , stanzaFrom = mfrom + , stanzaChan = chan + , stanzaClosers = clsrs + , stanzaInterrupt = donevar + , stanzaOrigin = NetworkOrigin k output + } + ioWriteChan stanzas s + flip (maybe $ unrecog) dispatch $ \dispatch -> case dispatch of Ping -> do -- TODO: check that the to-address matches this server. -- Otherwise it could be a client-to-client ping or a -- client-to-server for some other server. -- For now, assuming its for the immediate connection. - let to = maybe "todo" id mto - from = maybe "todo" id mfrom - let pong = makePong namespace mid to from - -- liftIO $ wlog "got ping, sending pong..." - pongStanza <- liftIO . atomically $ do - pongChan <- newTChan - pongClsrs <- newTVar (Just []) - return Stanza { stanzaType = Pong - , stanzaId = mid - , stanzaTo = mto - , stanzaFrom = mfrom - , stanzaChan = pongChan - , stanzaClosers = pongClsrs - , stanzaInterrupt = donevar - , stanzaOrigin = LocalPeer - } - ioWriteChan output pongStanza - void . liftIO . forkIO $ do - mapM_ (ioWriteChan $ stanzaChan pongStanza) pong - liftIO . atomically $ writeTVar (stanzaClosers pongStanza) Nothing - -- liftIO $ wlog "finished pong stanza" - + let pongto = maybe "todo" id mfrom + pongfrom = maybe "todo" id mto + pong = makePong namespace mid pongto pongfrom + sendReply donevar Pong pong output -- TODO: Remove this, it is only to generate a debug print ioWriteChan stanzas Stanza { stanzaType = Ping @@ -265,7 +287,7 @@ xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do , stanzaChan = chan , stanzaClosers = clsrs , stanzaInterrupt = donevar - , stanzaOrigin = NetworkOrigin k + , stanzaOrigin = NetworkOrigin k output } stype -> ioWriteChan stanzas Stanza { stanzaType = stype @@ -275,7 +297,7 @@ xmppInbound sv k pingflag src stanzas output donevar = doNestingXML $ do , stanzaChan = chan , stanzaClosers = clsrs , stanzaInterrupt = donevar - , stanzaOrigin = NetworkOrigin k + , stanzaOrigin = NetworkOrigin k output } awaitCloser stanza_lvl liftIO . atomically $ writeTVar clsrs Nothing @@ -334,6 +356,22 @@ greet' namespace host = ] ] ++ streamFeatures namespace +consid Nothing = id +consid (Just sid) = (("id",[ContentText sid]):) + +iq_bind_reply :: Maybe Text -> Text -> [XML.Event] +iq_bind_reply mid jid = + [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])]) + , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" + [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])] + , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" [] + , EventContent (ContentText jid) + , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" + , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" + , EventEndElement "{jabber:client}iq" + ] + +{- greet namespace = [ EventBeginDocument , EventBeginElement (streamP "stream") @@ -341,6 +379,7 @@ greet namespace = , attr "version" "1.0" ] ] +-} goodbye = [ EventEndElement (streamP "stream") @@ -403,12 +442,14 @@ forkConnection sv k pingflag src snk stanzas = do [Slotted.pull slots >>= \x -> do writeTVar needsFlush True return $ do + -- liftIO $ wlog $ "yielding Chunk: " ++ show x yield (Chunk x) slot_src ,do Slotted.isEmpty slots >>= check readTVar needsFlush >>= check writeTVar needsFlush False return $ do + -- liftIO $ wlog "yielding Flush" yield Flush slot_src ,readTMVar rdone >> return (return ()) @@ -501,9 +542,14 @@ stanzaToConduit stanza = do return (return ())] what +socketFromKey :: Server k -> k -> IO Socket +socketFromKey sv k = do + return todo + monitor sv params = do chan <- return $ serverEvent sv stanzas <- atomically newTChan + quitVar <- atomically newEmptyTMVar fix $ \loop -> do action <- atomically $ foldr1 orElse [ readTChan chan >>= \(k,e) -> return $ do @@ -513,8 +559,7 @@ monitor sv params = do let (xsrc,xsnk) = xmlStream conread conwrite forkConnection sv k pingflag xsrc xsnk stanzas return () - ConnectFailure addr -> do - wlog $ tomsg k "ConnectFailure" + ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure" EOF -> wlog $ tomsg k "EOF" HalfConnection In -> do wlog $ tomsg k "ReadOnly" @@ -523,13 +568,22 @@ monitor sv params = do RequiresPing -> return () -- wlog $ tomsg k "RequiresPing" _ -> return () , readTChan stanzas >>= \stanza -> return $ do + forkIO $ do + case (stanzaType stanza,stanzaOrigin stanza) of + (RequestResource wanted, NetworkOrigin k@(ClientKey{}) replyto) -> do + sock <- socketFromKey sv k + rsc <- getResourceName sock wanted + let reply = iq_bind_reply (stanzaId stanza) rsc + sendReply quitVar SetResource reply replyto + _ -> return () let typ = Strict8.pack $ c ++ "->"++(show (stanzaType stanza))++" " c = case stanzaOrigin stanza of LocalPeer -> "*" - NetworkOrigin (ClientKey {}) -> "C" - NetworkOrigin (PeerKey {}) -> "P" + NetworkOrigin (ClientKey {}) _ -> "C" + NetworkOrigin (PeerKey {}) _ -> "P" wlog "" stanzaToConduit stanza $$ prettyPrint typ + ] action loop -- cgit v1.2.3