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

@@ -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

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
 

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,15 +113,57 @@ 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

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