From cd9f42e58fd61acec4f8a39c21a245ba1a84859e Mon Sep 17 00:00:00 2001 From: Jon Kristensen Date: Sun, 17 Jun 2012 02:14:42 +0200 Subject: [PATCH] extended stream pickling and validation pickleStream now (liberal) pickleInStream and (strict) pickleOutStream xmppStream validates most of the stream element received and throws errors connect catches the errors thrown by xmppStream, generates stream errors made it possible to have the prefered language for the stream in the state communicate the prefered stream language if it's set extract stream language from incoming stream exported langTag function in Types --- source/Network/Xmpp.hs | 32 +++++++++++- source/Network/Xmpp/Monad.hs | 3 ++ source/Network/Xmpp/Stream.hs | 96 ++++++++++++++++++++++++++++------- source/Network/Xmpp/Types.hs | 13 ++++- 4 files changed, 122 insertions(+), 22 deletions(-) diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index abaad61..d1015ae 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -154,8 +154,10 @@ import qualified Network.TLS as TLS import Network.Xmpp.Bind import Network.Xmpp.Concurrent import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Marshal import Network.Xmpp.Message import Network.Xmpp.Monad +import Network.Xmpp.Pickle import Network.Xmpp.Presence import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Mechanisms @@ -169,7 +171,35 @@ import Control.Monad.Error -- | Connect to host with given address. connect :: HostName -> Text -> XmppConMonad (Either StreamError ()) -connect address hostname = xmppRawConnect address hostname >> xmppStartStream +connect address hostname = do + xmppRawConnect address hostname + result <- xmppStartStream + case result of + -- TODO: Descriptive texts in stream errors? + Left (StreamNotStreamElement _name) -> do + _ <- pushElement $ pickleElem xpStreamError $ + XmppStreamError StreamInvalidXml Nothing Nothing + return () + Left (StreamInvalidStreamNamespace _ns) -> do + _ <- pushElement $ pickleElem xpStreamError $ + XmppStreamError StreamInvalidNamespace Nothing Nothing + return () + Left (StreamInvalidStreamPrefix _prefix) -> do + _ <- pushElement $ pickleElem xpStreamError $ + XmppStreamError StreamBadNamespacePrefix Nothing Nothing + return () + -- TODO: Catch remaining xmppStartStream errors. + Left (StreamWrongVersion _ver) -> do + _ <- pushElement $ pickleElem xpStreamError $ + XmppStreamError StreamUnsupportedVersion Nothing Nothing + return () + Left (StreamWrongLangTag _lang) -> do + _ <- pushElement $ pickleElem xpStreamError $ + XmppStreamError StreamInvalidXml Nothing Nothing + return () + Right () -> + return () + return result -- | Authenticate to the server using the first matching method and bind a diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs index f017895..ab63847 100644 --- a/source/Network/Xmpp/Monad.hs +++ b/source/Network/Xmpp/Monad.hs @@ -115,6 +115,7 @@ xmppNoConnection = XmppConnection , sHostname = Nothing , sJid = Nothing , sCloseConnection = return () + , sStreamLang = Nothing } where zeroSource :: Source IO output @@ -140,6 +141,8 @@ xmppRawConnect host hostname = do , sHostname = (Just hostname) , sJid = Nothing , sCloseConnection = (hClose con) + , sPreferredLang = Nothing -- TODO: Allow user to set + , sStreamLang = Nothing } put st diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 52fba97..2cddb26 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -3,6 +3,7 @@ module Network.Xmpp.Stream where +import Control.Applicative ((<$>), (<*>)) import qualified Control.Exception as Ex import Control.Monad.Error import Control.Monad.State.Strict @@ -10,6 +11,7 @@ import Control.Monad.State.Strict import Data.Conduit import Data.Conduit.BufferedSource import Data.Conduit.List as CL +import Data.Maybe (fromJust, isJust, isNothing) import Data.Text as T import Data.XML.Pickle import Data.XML.Types @@ -59,14 +61,15 @@ openElementFromEvents = do xmppStartStream :: XmppConMonad (Either StreamError ()) xmppStartStream = runErrorT $ do hostname' <- gets sHostname + lang <- gets sPreferredLang case hostname' of Nothing -> throwError StreamConnectionError Just hostname -> lift $ do pushXmlDecl pushOpenElement $ - pickleElem pickleStream ("1.0", Nothing, Just hostname) - features <- ErrorT . pullToSink $ runErrorT xmppStream - modify (\s -> s {sFeatures = features}) + pickleElem pickleOutStream (Nothing, Just hostname, (pack . show) <$> lang) + (lt, features) <- ErrorT . pullToSink $ runErrorT xmppStream + modify (\s -> s {sFeatures = features, sStreamLang = Just lt}) return () -- Creates a new connection source (of Events) using the raw source (of bytes) @@ -79,17 +82,30 @@ xmppRestartStream = do xmppStartStream -- Reads the (partial) stream:stream and the server features from the stream. -xmppStream :: StreamSink ServerFeatures +-- Throws an error the version number is not 1.0, or if the language tag is not +-- set, or is invalid. +xmppStream :: StreamSink (LangTag, ServerFeatures) xmppStream = do - xmppStreamHeader - xmppStreamFeatures + langTag <- xmppStreamHeader + features <- xmppStreamFeatures + return (langTag, features) where - xmppStreamHeader :: StreamSink () + xmppStreamHeader :: StreamSink LangTag xmppStreamHeader = do - lift $ throwOutJunk - (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents - unless (ver == "1.0") . throwError $ StreamWrongVersion ver - return () + lift throwOutJunk + -- Get the stream:stream element (or whatever it is) from the server, + -- and validate what we get. + ((Name lname ns prefix), (from, id, to, ver, lang, xns), ()) + <- streamUnpickleElem pickleInStream =<< openElementFromEvents + unless (lname == "stream") $ throwError $ StreamNotStreamElement lname + unless ((ns == Just "jabber:client" && xns == Just "http://etherx.jabber.org/streams") || (ns == Just "http://etherx.jabber.org/streams" && (xns == Just"" || xns == Nothing))) $ throwError $ StreamInvalidStreamNamespace (ns, xns) + unless (prefix == Just "stream") $ throwError $ StreamInvalidStreamPrefix prefix + unless (ver == Just "1.0") $ throwError $ StreamWrongVersion ver + -- TODO: Verify id, to, from, and stream:xmlns. + liftIO $ print (from, id, to, ver, lang, xns) + let lang_ = maybe Nothing langTag lang + when (isNothing lang_) $ throwError $ StreamWrongLangTag lang + return $ fromJust lang_ xmppStreamFeatures :: StreamSink ServerFeatures xmppStreamFeatures = do e <- lift $ elements =$ CL.head @@ -97,16 +113,58 @@ xmppStream = do Nothing -> liftIO $ Ex.throwIO StreamConnectionError Just r -> streamUnpickleElem pickleStreamFeatures r --- Pickler/Unpickler for the stream, with the version, from and to attributes. -pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) -pickleStream = xpElemAttrs - (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - (xpTriple - (xpAttr "version" xpId) - (xpOption $ xpAttr "from" xpId) - (xpOption $ xpAttr "to" xpId) +-- Pickler for the stream element to be sent to the server. Version "1.0" is +-- assumed, and so is the "jabber:client" xmlns and +-- "http://etherx.jabber.org/streams" xmlns:stream attributes. (We follow what +-- RFC 6120 calls the "content-namespace-as-default-namespace".) +pickleOutStream :: PU [Node] ( Maybe Text -- from + , Maybe Text -- to + , Maybe Text -- xml:lang + ) +pickleOutStream = xpWrap + (\(from, to, _ver, lang) -> (from, to, lang)) + (\(from, to, lang) -> + (from, to, "1.0", lang) + ) + (xpElemAttrs + (Name + "stream" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) + (xp4Tuple + (xpAttrImplied "from" xpId) + (xpAttrImplied "to" xpId) + (xpAttr "version" xpId) + (xpAttrImplied (Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")) xpId) + ) ) +-- Unpickler for the stream element to be received from the server. As this +-- function puts no restrictions on the element received, the data need to be +-- validated externally. +pickleInStream :: PU [Node] ( Name + , ( Maybe Text -- from + , Maybe Text -- id + , Maybe Text -- to + , Maybe Text -- version + , Maybe Text -- xml:lang + , Maybe Text -- xmlns:stream + ) + , () + ) +pickleInStream = xpElemWithName + (xp6Tuple + (xpAttrImplied "from" xpId) + (xpAttrImplied "id" xpId) + (xpAttrImplied "to" xpId) + (xpAttrImplied "version" xpId) + (xpAttrImplied (Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")) xpId) + -- TODO: Actually fetch the xmlns:stream attribute. + (xpAttrImplied (Name "stream" Nothing (Just "xmlns")) xpId) + ) + xpUnit + -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. pickleStreamFeatures :: PU [Node] ServerFeatures pickleStreamFeatures = xpWrap diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 704e4ca..f547a1c 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -30,12 +30,14 @@ module Network.Xmpp.Types , StanzaErrorType(..) , StanzaId(..) , StreamError(..) + , StreamErrorCondition(..) , Version(..) , XmppConMonad , XmppConnection(..) , XmppConnectionState(..) , XmppT(..) , XmppStreamError(..) + , langTag , module Network.Xmpp.Jid ) where @@ -530,7 +532,11 @@ data XmppStreamError = XmppStreamError } deriving (Show, Eq) data StreamError = StreamError XmppStreamError - | StreamWrongVersion Text + | StreamNotStreamElement Text + | StreamInvalidStreamNamespace (Maybe Text, Maybe Text) + | StreamInvalidStreamPrefix (Maybe Text) + | StreamWrongVersion (Maybe Text) + | StreamWrongLangTag (Maybe Text) | StreamXMLError String -- If stream pickling goes wrong. | StreamStreamEnd -- received closing stream tag | StreamConnectionError @@ -653,7 +659,10 @@ data XmppConnection = XmppConnection , sHostname :: Maybe Text , sJid :: Maybe Jid , sCloseConnection :: IO () - -- TODO: add default Language + , sPreferredLang :: Maybe LangTag + , sStreamLang :: Maybe LangTag -- Will be a `Just' value + -- once connected to the + -- server. } -- |