From 3b02df0ba4b81731a5c36e98a9dd69a37a0c4635 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 29 Nov 2015 17:52:35 +0100 Subject: [PATCH] implement handling of nonzas (#96) https://xmpp.org/extensions/xep-0360.html --- source/Network/Xmpp/Concurrent.hs | 32 ++++++++++++++--------- source/Network/Xmpp/Concurrent/Basic.hs | 9 +++++++ source/Network/Xmpp/Concurrent/Threads.hs | 10 +++---- source/Network/Xmpp/Concurrent/Types.hs | 19 +++++++------- source/Network/Xmpp/IM/PresenceTracker.hs | 2 +- source/Network/Xmpp/IM/Roster.hs | 8 +++--- source/Network/Xmpp/Lens.hs | 15 ++++++++++- source/Network/Xmpp/Marshal.hs | 11 ++++++++ source/Network/Xmpp/Stream.hs | 17 +++++++++--- source/Network/Xmpp/Types.hs | 7 ++++- 10 files changed, 93 insertions(+), 37 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 96ea431..2877114 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -53,7 +53,12 @@ import System.Random (randomRIO) import Control.Monad.State.Strict -runHandlers :: [Stanza -> [Annotation] -> IO [Annotated Stanza]] -> Stanza -> IO () +runHandlers :: [ XmppElement + -> [Annotation] + -> IO [Annotated XmppElement] + ] + -> XmppElement + -> IO () runHandlers [] sta = do errorM "Pontarius.Xmpp" $ "No stanza handlers set, discarding stanza" ++ show sta @@ -66,17 +71,20 @@ runHandlers hs sta = go hs sta [] toChan :: TChan (Annotated Stanza) -> StanzaHandler toChan stanzaC _ sta as = do - atomically $ writeTChan stanzaC (sta, as) + case sta of + XmppStanza s -> atomically $ writeTChan stanzaC (s, as) + _ -> return () return [(sta, [])] handleIQ :: TVar IQHandlers -> StanzaHandler -handleIQ iqHands out sta as = do +handleIQ _ _ s@XmppNonza{} _ = return [(s, [])] +handleIQ iqHands out s@(XmppStanza sta) as = do case sta of IQRequestS i -> handleIQRequest iqHands i >> return [] IQResultS i -> handleIQResponse iqHands (Right i) >> return [] IQErrorS i -> handleIQResponse iqHands (Left i) >> return [] - _ -> return [(sta, [])] + _ -> return [(s, [])] where -- If the IQ request has a namespace, send it through the appropriate channel. handleIQRequest :: TVar IQHandlers -> IQRequest -> IO () @@ -106,7 +114,7 @@ handleIQ iqHands out sta as = do atomically $ putTMVar sentRef True return Nothing False -> do - didSend <- out response + didSend <- out $ XmppStanza response case didSend of Right () -> do atomically $ putTMVar sentRef True @@ -116,7 +124,7 @@ handleIQ iqHands out sta as = do return $ Just er writeTChan ch $ IQRequestTicket answerT iq as return Nothing - maybe (return ()) (void . out) res + maybe (return ()) (void . out . XmppStanza) res serviceUnavailable (IQRequest iqid from _to lang _tp bd _attrs) = IQErrorS $ IQError iqid Nothing from lang err (Just bd) [] err = StanzaError Cancel ServiceUnavailable Nothing Nothing @@ -176,23 +184,23 @@ newSession stream config realm mbSasl = runErrorT $ do rosRef <- liftIO $ newTVarIO ros peers <- liftIO . newTVarIO $ Peers Map.empty rew <- lift $ newTVarIO 60 - let out = writeStanza writeSem + let out = writeXmppElem writeSem boundJid <- liftIO $ withStream' (gets streamJid) stream let rosterH = if (enableRoster config) then [handleRoster boundJid rosRef (fromMaybe (\_ -> return ()) $ onRosterPush config) - out] + (out)] else [] let presenceH = if (enablePresenceTracking config) then [handlePresence (onPresenceChange config) peers out] else [] - (sStanza, ps) <- initPlugins out $ plugins config + (sXmppElement, ps) <- initPlugins out $ plugins config let stanzaHandler = runHandlers $ List.concat [ inHandler <$> ps - , [ toChan stanzaChan sStanza] + , [ toChan stanzaChan sXmppElement] , presenceH , rosterH - , [ handleIQ iqHands sStanza] + , [ handleIQ iqHands sXmppElement] ] (kill, sState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream @@ -209,7 +217,7 @@ newSession stream config realm mbSasl = runErrorT $ do , conf = config , rosterRef = rosRef , presenceRef = peers - , sendStanza' = sStanza + , sendStanza' = sXmppElement . XmppStanza , sRealm = realm , sSaslCredentials = mbSasl , reconnectWait = rew diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs index dc526f2..8af96a1 100644 --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -17,6 +17,15 @@ semWrite sem bs = Ex.bracket (atomically $ takeTMVar sem) (atomically . putTMVar sem) ($ bs) +writeXmppElem :: WriteSemaphore -> XmppElement -> IO (Either XmppFailure ()) +writeXmppElem sem a = do + let el = case a of + XmppStanza s -> pickleElem xpStanza s + XmppNonza n -> n + outData = renderElement $ nsHack el + debugOut outData + semWrite sem outData + writeStanza :: WriteSemaphore -> Stanza -> IO (Either XmppFailure ()) writeStanza sem a = do let outData = renderElement $ nsHack (pickleElem xpStanza a) diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index d5b57ac..83c2220 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -19,11 +19,11 @@ import System.Log.Logger -- Worker to read stanzas from the stream and concurrently distribute them to -- all listener threads. -readWorker :: (Stanza -> IO ()) +readWorker :: (XmppElement -> IO ()) -> (XmppFailure -> IO ()) -> TMVar Stream -> IO a -readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do +readWorker onElement onCClosed stateRef = forever . Ex.mask_ $ do s' <- Ex.catches ( do atomically $ do s@(Stream con) <- readTMVar stateRef @@ -44,7 +44,7 @@ readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do -- we don't know whether pull will -- necessarily be interruptible allowInterrupt - res <- pullStanza s + res <- pullXmppElement s case res of Left e -> do errorM "Pontarius.Xmpp" $ "Read error: " @@ -61,7 +61,7 @@ readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do case res of Nothing -> return () -- Caught an exception, nothing to -- do. TODO: Can this happen? - Just sta -> void $ onStanza sta + Just sta -> void $ onElement sta where -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 -- compatibility. @@ -82,7 +82,7 @@ readWorker onStanza onCClosed stateRef = forever . Ex.mask_ $ do -- stances, respectively, and an Action to stop the Threads and close the -- connection. startThreadsWith :: TMVar (BS.ByteString -> IO (Either XmppFailure ())) - -> (Stanza -> IO ()) + -> (XmppElement -> IO ()) -> TMVar EventHandlers -> Stream -> Maybe Int diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index aca4939..59a72ee 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -21,11 +21,12 @@ import Network.Xmpp.IM.PresenceTracker.Types import Network.Xmpp.Sasl.Types import Network.Xmpp.Types -type StanzaHandler = (Stanza -> IO (Either XmppFailure ()) ) -- ^ outgoing stanza - -> Stanza -- ^ stanza to handle +type StanzaHandler = (XmppElement -> IO (Either XmppFailure ()) ) -- ^ outgoing + -- stanza + -> XmppElement -- ^ stanza to handle -> [Annotation] -- ^ annotations added by previous handlers - -> IO [(Stanza, [Annotation])] -- ^ modified stanzas and - -- /additional/ annotations + -> IO [(XmppElement, [Annotation])] -- ^ modified stanzas and + -- /additional/ annotations type Resource = Text @@ -56,17 +57,17 @@ getAnnotation = foldr (\(Annotation a) b -> maybe b Just $ cast a) Nothing . snd data Plugin' = Plugin' { -- | Resulting stanzas and additional Annotations - inHandler :: Stanza + inHandler :: XmppElement -> [Annotation] - -> IO [(Stanza, [Annotation])] - , outHandler :: Stanza -> IO (Either XmppFailure ()) + -> IO [(XmppElement, [Annotation])] + , outHandler :: XmppElement -> IO (Either XmppFailure ()) -- | In order to allow plugins to tie the knot (Plugin / Session) we pass -- the plugin the completed Session once it exists , onSessionUp :: Session -> IO () } -type Plugin = (Stanza -> IO (Either XmppFailure ())) -- ^ pass stanza to next - -- plugin +type Plugin = (XmppElement -> IO (Either XmppFailure ())) -- ^ pass stanza to + -- next plugin -> ErrorT XmppFailure IO Plugin' -- | Configuration for the @Session@ object. diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs index 5e4cd1b..dbd807d 100644 --- a/source/Network/Xmpp/IM/PresenceTracker.hs +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -64,7 +64,7 @@ handlePresence :: Maybe (Jid -> PeerStatus -> PeerStatus -> IO ()) -> StanzaHandler handlePresence onChange peers _ st _ = do let mbPr = do - pr <- st ^? _Presence -- Only act on presence stanzas + pr <- st ^? _Stanza . _Presence -- Only act on presence stanzas fr <- pr ^? from . _Just . _isFull -- Only act on full JIDs return (pr, fr) Foldable.forM_ mbPr $ \(pr, fr) -> diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 7f54b96..cd36f99 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -104,8 +104,8 @@ handleRoster :: Maybe Jid -> StanzaHandler handleRoster mbBoundJid ref onUpdate out sta _ = do case sta of - IQRequestS (iqr@IQRequest{iqRequestPayload = - iqb@Element{elementName = en}}) + XmppStanza (IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}})) | nameNamespace en == Just "jabber:iq:roster" -> do let doHandle = case (iqRequestFrom iqr, mbBoundJid) of -- We don't need to check our own JID when the IQ @@ -124,11 +124,11 @@ handleRoster mbBoundJid ref onUpdate out sta _ = do } -> do handleUpdate v update onUpdate update - _ <- out $ result iqr + _ <- out . XmppStanza $ result iqr return [] _ -> do errorM "Pontarius.Xmpp" "Invalid roster query" - _ <- out $ badRequest iqr + _ <- out . XmppStanza $ badRequest iqr return [] -- Don't handle roster pushes from unauthorized sources else return [(sta, [])] diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index 22da900..dc2bfc5 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -51,7 +51,9 @@ module Network.Xmpp.Lens , _isFull , _isBare - -- ** Stanzas + -- ** Stanzas and Nonzas + , _Stanza + , _Nonza , _IQRequest , _IQResult , _IQError @@ -212,6 +214,17 @@ _isFull = prism' id (\j -> if isFull j then Just j else Nothing) _isBare :: Prism Jid Jid _isBare = prism' toBare (\j -> if isBare j then Just j else Nothing) +_Stanza :: Prism XmppElement Stanza +_Stanza = prism' XmppStanza (\v -> case v of + XmppStanza s -> Just s + _ -> Nothing) + +_Nonza :: Prism XmppElement Element +_Nonza = prism' XmppNonza (\v -> case v of + XmppNonza n -> Just n + _ -> Nothing) + + class IsStanza s where -- | From-attribute of the stanza from :: Lens s (Maybe Jid) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 7d3e89d..cca8bf5 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -22,6 +22,17 @@ import Network.Xmpp.Types xpNonemptyText :: PU Text NonemptyText xpNonemptyText = ("xpNonemptyText" , "") xpWrap Nonempty fromNonempty xpText +xpStreamElement :: PU [Node] (Either StreamErrorInfo XmppElement) +xpStreamElement = xpEither xpStreamError $ + xpWrap (\v -> case v of + Left l -> XmppStanza l + Right r -> XmppNonza r + ) + ( \v -> case v of + XmppStanza l -> Left l + XmppNonza r -> Right r) + $ xpEither xpStanza xpElemVerbatim + xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 5e99b83..780c32f 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -239,6 +239,7 @@ restartStream = do startStream +-- Creates a conduit from a StreamHandle sourceStreamHandle :: (MonadIO m, MonadError XmppFailure m) => StreamHandle -> ConduitM i ByteString m () sourceStreamHandle s = loopRead $ streamReceive s @@ -395,11 +396,10 @@ pushElement x = do let outData = renderElement $ nsHack x debugOut outData lift $ send outData - where - -- HACK: We remove the "jabber:client" namespace because it is set as - -- default in the stream. This is to make isode's M-LINK server happy and - -- should be removed once jabber.org accepts prefix-free canonicalization +-- HACK: We remove the "jabber:client" namespace because it is set as +-- default in the stream. This is to make isode's M-LINK server happy and +-- should be removed once jabber.org accepts prefix-free canonicalization nsHack :: Element -> Element nsHack e@(Element{elementName = n}) | nameNamespace n == Just "jabber:client" = @@ -477,6 +477,15 @@ pullStanza = withStream' $ do Right (Left e) -> return $ Left $ StreamErrorFailure e Right (Right r) -> return $ Right r +-- | Pulls a stanza, nonza or stream error from the stream. +pullXmppElement :: Stream -> IO (Either XmppFailure XmppElement) +pullXmppElement = withStream' $ do + res <- pullUnpickle xpStreamElement + case res of + Left e -> return $ Left e + Right (Left e) -> return $ Left $ StreamErrorFailure e + Right (Right r) -> return $ Right r + -- Performs the given IO operation, catches any errors and re-throws everything -- except 'ResourceVanished' and IllegalOperation, which it will return. catchPush :: IO () -> IO (Either XmppFailure ()) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 740f1e3..f1361ae 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -42,6 +42,7 @@ module Network.Xmpp.Types , SaslFailure(..) , StreamFeatures(..) , Stanza(..) + , XmppElement(..) , messageS , messageErrorS , presenceS @@ -138,7 +139,11 @@ nonEmpty txt = if Text.all isSpace txt then Nothing else Just (Nonempty txt) text :: NonemptyText -> Text text (Nonempty txt) = txt --- | The Xmpp communication primities (Message, Presence and Info/Query) are +data XmppElement = XmppStanza !Stanza + | XmppNonza !Element + deriving (Eq, Show) + +-- | The Xmpp communication primitives (Message, Presence and Info/Query) are -- called stanzas. data Stanza = IQRequestS !IQRequest | IQResultS !IQResult