XmppConnection fields for jid to put in outgoing stream `from'

validate incoming stream `to'
using Jid instead of Text in pickleOutStream
don't read xmlns:stream attribute on incoming stream
close the stream after sending the stream errors
save `from' as specified by the server
documentation corrections

source/Network/Xmpp/Monad.hs

@@ -116,6 +116,10 @@ xmppNoConnection = XmppConnection
                , sJid              = Nothing
                , sCloseConnection  = return ()
                , sStreamLang       = Nothing
+               , sPreferredLang    = Nothing
+               , sToJid            = Nothing
+               , sJidWhenPlain     = False
+               , sFrom             = Nothing
                }
   where
     zeroSource :: Source IO output
@@ -143,6 +147,9 @@ xmppRawConnect host hostname = do
             , sCloseConnection = (hClose con)
             , sPreferredLang   = Nothing -- TODO: Allow user to set
             , sStreamLang      = Nothing
+            , sToJid           = Nothing -- TODO: Allow user to set
+            , sJidWhenPlain    = False -- TODO: Allow user to set
+            , sFrom            = Nothing
             }
     put st
 

source/Network/Xmpp/Stream.hs

@@ -60,16 +60,23 @@ openElementFromEvents = do
 -- Sends the initial stream:stream element and pulls the server features.
 xmppStartStream :: XmppConMonad (Either StreamError ())
 xmppStartStream = runErrorT $ do
-    hostname' <- gets sHostname
+    state <- get
-    lang <- gets sPreferredLang
+    -- Set the `to' attribute depending on the state of the connection.
-    case hostname' of
+    let to = case sConnectionState state of
+                 XmppConnectionPlain -> if sJidWhenPlain state
+                                        then sJid state else Nothing
+                 XmppConnectionSecured -> sJid state
+    case sHostname state of
         Nothing -> throwError StreamConnectionError
         Just hostname -> lift $ do
             pushXmlDecl
             pushOpenElement $
-                pickleElem pickleOutStream (Nothing, Just hostname, lang)
+                pickleElem pickleOutStream ( to
-    (lt, features) <- ErrorT . pullToSink $ runErrorT xmppStream
+                                           , Just hostname
-    modify (\s -> s {sFeatures = features, sStreamLang = Just lt})
+                                           , sPreferredLang state
+                                           )
+    (lt, from, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream to
+    modify (\s -> s {sFeatures = features, sStreamLang = Just lt, sFrom = from})
     return ()
 
 -- Creates a new connection source (of Events) using the raw source (of bytes)
@@ -82,29 +89,30 @@ xmppRestartStream = do
     xmppStartStream
 
 -- Reads the (partial) stream:stream and the server features from the stream.
--- Throws an error the version number is not 1.0, or if the language tag is not
+-- Also validates the stream element's attributes and throws an error if
--- set, or is invalid.
+-- appropriate.
-xmppStream :: StreamSink (LangTag, ServerFeatures)
+xmppStream :: Maybe Jid -> StreamSink (LangTag, Maybe Text, ServerFeatures)
-xmppStream = do
+xmppStream expectedTo = do
-    langTag <- xmppStreamHeader
+    (langTag, from) <- xmppStreamHeader
     features <- xmppStreamFeatures
-    return (langTag, features)
+    return (langTag, from, features)
   where
-    xmppStreamHeader :: StreamSink LangTag
+    xmppStreamHeader :: StreamSink (LangTag, Maybe Text)
     xmppStreamHeader = do
         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), ())
+        ((Name lname ns prefix), (from, id, to, ver, lang), ())
             <- 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 (ns == Just "http://etherx.jabber.org/streams") $ throwError $ StreamInvalidStreamNamespace ns
         unless (prefix == Just "stream") $ throwError $ StreamInvalidStreamPrefix prefix
+        unless (isNothing to || (fromText $ fromJust to) == expectedTo) $ throwError $ StreamWrongTo to
         unless (ver == Just "1.0") $ throwError $ StreamWrongVersion ver
-        -- TODO: Verify id, to, from, and stream:xmlns.
+        -- TODO: Verify id and from.
         let lang_ = maybe Nothing langTag lang
         when (isNothing lang_) $ throwError $ StreamWrongLangTag lang
-        return $ fromJust lang_
+        return (fromJust lang_, from)
     xmppStreamFeatures :: StreamSink ServerFeatures
     xmppStreamFeatures = do
         e <- lift $ elements =$ CL.head
@@ -112,11 +120,9 @@ xmppStream = do
             Nothing -> liftIO $ Ex.throwIO StreamConnectionError
             Just r -> streamUnpickleElem xpStreamFeatures r
 
--- Pickler for the stream element to be sent to the server. Version "1.0" is
+-- Pickler for the stream element to be sent to the server. We follow what RFC
--- assumed, and so is the "jabber:client" xmlns and
+-- 6120 calls the "prefix-free canonicalization style".)
--- "http://etherx.jabber.org/streams" xmlns:stream attributes. (We follow what
+pickleOutStream :: PU [Node] ( Maybe Jid -- from
--- RFC 6120 calls the "content-namespace-as-default-namespace".)
-pickleOutStream :: PU [Node] ( Maybe Text -- from
                              , Maybe Text -- to
                              , Maybe LangTag -- xml:lang
                              )
@@ -132,7 +138,7 @@ pickleOutStream = xpWrap
               (Just "stream")
          )
          (xp4Tuple
-              (xpAttrImplied "from" xpId)
+              (xpAttrImplied "from" xpPrim)
               (xpAttrImplied "to" xpId)
               (xpAttr "version" xpId)
               xpLangTag
@@ -148,19 +154,16 @@ pickleInStream :: PU [Node] ( Name
                               , Maybe Text -- to
                               , Maybe Text -- version
                               , Maybe Text -- xml:lang
-                              , Maybe Text -- xmlns:stream
                               )
                             , ()
                             )
 pickleInStream = xpElemWithName
-    (xp6Tuple
+    (xp5Tuple
          (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
  

source/Network/Xmpp/Types.hs

@@ -618,8 +618,9 @@ data XmppStreamError = XmppStreamError
 
 data StreamError = StreamError XmppStreamError
                  | StreamNotStreamElement Text
-                 | StreamInvalidStreamNamespace (Maybe Text, Maybe Text)
+                 | StreamInvalidStreamNamespace (Maybe Text)
                  | StreamInvalidStreamPrefix (Maybe Text)
+                 | StreamWrongTo (Maybe Text)
                  | StreamWrongVersion (Maybe Text)
                  | StreamWrongLangTag (Maybe Text) 
                  | StreamXMLError String -- If stream pickling goes wrong.
@@ -748,6 +749,15 @@ data XmppConnection = XmppConnection
                , sStreamLang      :: Maybe LangTag -- Will be a `Just' value
                                                    -- once connected to the
                                                    -- server.
+               , sToJid           :: Maybe Jid -- JID to include in the stream
+                                               -- element's `to' attribute when
+                                               -- the connection is secured. See
+                                               -- also below.
+               , sJidWhenPlain    :: Bool -- Whether or not to also include the
+                                          -- Jid when the connection is plain.
+               , sFrom            :: Maybe Text -- From as specified by the
+                                                -- server in the stream
+                                                -- element's `from' attribute.
                }
 
 -- |