From a1d027940e5838f2d2c523a33a51fe9abdd92846 Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Thu, 3 Jan 2013 06:34:51 +0100 Subject: [PATCH] Re-add `findStreamErrors' functionality The library should now generate the proper stream errors again, in case of received stream open element problem. The return type of streamS has been modified so that the validation can be performed in startStream instead, and without exceptions. This will also help enable implementation of logging later. The Errors module has been removed. --- source/Network/Xmpp/Errors.hs | 14 ---- source/Network/Xmpp/Stream.hs | 138 +++++++++++++++++++++++++--------- 2 files changed, 102 insertions(+), 50 deletions(-) delete mode 100644 source/Network/Xmpp/Errors.hs diff --git a/source/Network/Xmpp/Errors.hs b/source/Network/Xmpp/Errors.hs deleted file mode 100644 index 6e04d49..0000000 --- a/source/Network/Xmpp/Errors.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Errors where - -import Control.Applicative ((<$>)) -import Control.Monad(unless) -import Control.Monad.Error -import Control.Monad.Error.Class -import qualified Data.Text as Text -import Data.XML.Types -import Network.Xmpp.Types -import Network.Xmpp.Pickle - - diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 5e197ca..a06b3e3 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -24,13 +24,14 @@ import Network.Xmpp.Connection import Network.Xmpp.Errors import Network.Xmpp.Pickle import Network.Xmpp.Types +import Network.Xmpp.Marshal import Text.Xml.Stream.Elements import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements --- Unpickles and returns a stream element. Throws a StreamXmlError on failure. +-- Unpickles and returns a stream element. streamUnpickleElem :: PU [Node] a -> Element -> StreamSink a @@ -61,34 +62,98 @@ openElementFromEvents = do Just (EventBeginElement name attrs) -> return $ Element name attrs [] _ -> throwError $ StreamOtherFailure --- Sends the initial stream:stream element and pulls the server features. +-- Sends the initial stream:stream element and pulls the server features. If the +-- server responds in a way that is invalid, an appropriate stream error will be +-- generated, the connection to the server will be closed, and a StreamFilure +-- will be produced. startStream :: StateT Connection_ IO (Either StreamFailure ()) startStream = runErrorT $ do - state <- get - -- Set the `to' attribute depending on the state of the connection. - let from = case sConnectionState state of + state <- lift $ get + con <- liftIO $ mkConnection state + -- Set the `from' (which is also the expected to) attribute depending on the + -- state of the connection. + let expectedTo = case sConnectionState state of ConnectionPlain -> if sJidWhenPlain state then sJid state else Nothing ConnectionSecured -> sJid state case sHostname state of - Nothing -> throwError StreamOtherFailure + Nothing -> throwError StreamOtherFailure -- TODO: When does this happen? Just hostname -> lift $ do pushXmlDecl pushOpenElement $ pickleElem xpStream ( "1.0" - , from + , expectedTo , Just (Jid Nothing hostname Nothing) , Nothing , sPreferredLang state ) - (lt, from, id, features) <- ErrorT . runEventsSink $ runErrorT $ - streamS from - modify (\s -> s{ sFeatures = features - , sStreamLang = Just lt - , sStreamId = id - , sFrom = from - } ) - return () + response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo + case response of + -- Successful unpickling of stream element. + Right (ver, from, to, id, lt, features) + | (unpack $ fromJust id) /= "1.0" -> + closeStreamWithError con StreamUnsupportedVersion Nothing + | lt == Nothing -> + closeStreamWithError con StreamInvalidXml Nothing + -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? + | isJust from && (from /= Just (Jid Nothing (fromJust $ sHostname state) Nothing)) -> + closeStreamWithError con StreamInvalidFrom Nothing + | to /= expectedTo -> + closeStreamWithError con StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable? + | otherwise -> do + modify (\s -> s{ sFeatures = features + , sStreamLang = lt + , sStreamId = id + , sFrom = from + } ) + return () + -- Unpickling failed - we investigate the element. + Left (Element name attrs children) + | (nameLocalName name /= "stream") -> + closeStreamWithError con StreamInvalidXml Nothing + | (nameNamespace name /= Just "http://etherx.jabber.org/streams") -> + closeStreamWithError con StreamInvalidNamespace Nothing + | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") -> + closeStreamWithError con StreamBadNamespacePrefix Nothing + | otherwise -> ErrorT $ checkchildren con (flattenAttrs attrs) + where + -- closeStreamWithError :: MonadIO m => Connection -> StreamErrorCondition -> + -- Maybe Element -> ErrorT StreamFailure m () + closeStreamWithError con sec el = do + liftIO $ do + withConnection (pushElement . pickleElem xpStreamError $ + StreamErrorInfo sec Nothing el) con + closeStreams con + throwError StreamOtherFailure + checkchildren con children = + let to' = lookup "to" children + ver' = lookup "version" children + xl = lookup xmlLang children + in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') -> + runErrorT $ closeStreamWithError con + StreamBadNamespacePrefix Nothing + | Nothing == ver' -> + runErrorT $ closeStreamWithError con + StreamUnsupportedVersion Nothing + | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) -> + runErrorT $ closeStreamWithError con + StreamInvalidXml Nothing + | otherwise -> + runErrorT $ closeStreamWithError con + StreamBadFormat Nothing + safeRead x = case reads $ Text.unpack x of + [] -> Nothing + [(y,_),_] -> Just y + +flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] +flattenAttrs attrs = Prelude.map (\(name, content) -> + ( name + , Text.concat $ Prelude.map uncontentify content) + ) + attrs + where + uncontentify (ContentText t) = t + uncontentify _ = "" -- Sets a new Event source using the raw source (of bytes) -- and calls xmppStartStream. @@ -107,42 +172,43 @@ restartStream = do else yield bs >> loopRead read -- Reads the (partial) stream:stream and the server features from the stream. --- Also validates the stream element's attributes and throws an error if --- appropriate. +-- Returns the (unvalidated) stream attributes, the unparsed element, or +-- throwError throws a `StreamOtherFailure' (if something other than an element +-- was encountered at first, or if something other than stream features was +-- encountered second). -- TODO: from. -streamS :: Maybe Jid -> StreamSink ( LangTag - , Maybe Jid - , Maybe Text - , ServerFeatures) +streamS :: Maybe Jid -> StreamSink (Either Element ( Text + , Maybe Jid + , Maybe Jid + , Maybe Text + , Maybe LangTag + , ServerFeatures )) streamS expectedTo = do - (from, to, id, langTag) <- xmppStreamHeader - features <- xmppStreamFeatures - return (langTag, from, id, features) + header <- xmppStreamHeader + case header of + Right (version, from, to, id, langTag) -> do + features <- xmppStreamFeatures + return $ Right (version, from, to, id, langTag, features) + Left el -> return $ Left el where - xmppStreamHeader :: StreamSink (Maybe Jid, Maybe Jid, Maybe Text.Text, LangTag) + xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag)) xmppStreamHeader = do lift throwOutJunk -- Get the stream:stream element (or whatever it is) from the server, -- and validate what we get. - el <- openElementFromEvents + el <- openElementFromEvents -- May throw `StreamOtherFailure' if an + -- element is not received case unpickleElem xpStream el of - Left _ -> throwError StreamOtherFailure -- TODO: findStreamErrors el - Right r -> validateData r - - validateData (_, _, _, _, Nothing) = throwError StreamOtherFailure -- StreamWrongLangTag Nothing - validateData (ver, from, to, i, Just lang) - | ver /= "1.0" = throwError StreamOtherFailure -- StreamWrongVersion (Just ver) - | isJust to && to /= expectedTo = throwError StreamOtherFailure -- StreamWrongTo (Text.pack . show <$> to) - | otherwise = return (from, to, i, lang) + Left _ -> return $ Left el + Right r -> return $ Right r xmppStreamFeatures :: StreamSink ServerFeatures xmppStreamFeatures = do e <- lift $ elements =$ CL.head case e of - Nothing -> liftIO $ Ex.throwIO StreamOtherFailure + Nothing -> throwError StreamOtherFailure Just r -> streamUnpickleElem xpStreamFeatures r - xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag) xpStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))