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. } -- |