unsplit picklers

source/Network/Xmpp.hs

@@ -175,36 +175,27 @@ 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
+        Left e -> do
+            pushElement . pickleElem xpStreamError $ toError e
             xmppCloseStreams
             return ()
-        Left (StreamInvalidStreamNamespace _ns) -> do
-            _ <- pushElement $ pickleElem xpStreamError $
+        Right () -> return ()
+    return result
+  where
+        -- TODO: Descriptive texts in stream errors?
+        toError  (StreamNotStreamElement _name) =
+                XmppStreamError StreamInvalidXml Nothing Nothing
+        toError  (StreamInvalidStreamNamespace _ns) =
                 XmppStreamError StreamInvalidNamespace Nothing Nothing
-            xmppCloseStreams
-            return ()
-        Left (StreamInvalidStreamPrefix _prefix) -> do
-            _ <- pushElement $ pickleElem xpStreamError $
+        toError  (StreamInvalidStreamPrefix _prefix) =
                 XmppStreamError StreamBadNamespacePrefix Nothing Nothing
-            xmppCloseStreams
-            return ()
-        -- TODO: Catch remaining xmppStartStream errors.
-        Left (StreamWrongVersion _ver) -> do
-            _ <- pushElement $ pickleElem xpStreamError $
+        -- TO: Catch remaining xmppStartStream errors.
+        toError  (StreamWrongVersion _ver) =
                 XmppStreamError StreamUnsupportedVersion Nothing Nothing
-            xmppCloseStreams
-            return ()
-        Left (StreamWrongLangTag _lang) -> do
-            _ <- pushElement $ pickleElem xpStreamError $
+        toError  (StreamWrongLangTag _) =
                 XmppStreamError StreamInvalidXml Nothing Nothing
-            xmppCloseStreams
-            return ()
-        Right () ->
-            return ()
-    return result
+        toError  StreamUnknownError =
+                XmppStreamError StreamBadFormat Nothing Nothing
 
 
 -- | Authenticate to the server using the first matching method and bind a

source/Network/Xmpp/Errors.hs

@@ -0,0 +1,49 @@
+{-# 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
+
+
+-- Finds unpickling problems. Not to be used for data validation
+findStreamErrors :: Element -> StreamError
+findStreamErrors (Element name attrs children)
+    | (nameLocalName name /= "stream")
+        = StreamNotStreamElement $ nameLocalName name
+    | (nameNamespace name /= Just "http://etherx.jabber.org/streams")
+        = StreamInvalidStreamNamespace  $ nameNamespace name
+    | otherwise = checkchildren (flattenAttrs attrs)
+  where
+    checkchildren children =
+        let to'  = lookup "to"      children
+            ver' = lookup "version" children
+            xl   = lookup xmlLang   children
+          in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to')
+                             -> StreamWrongTo to'
+                           | Nothing == ver'
+                             -> StreamWrongVersion Nothing
+                           | Just (Nothing :: Maybe LangTag) ==
+                             (safeRead <$> xl)
+                             -> StreamWrongLangTag xl
+                           | otherwise
+                             -> StreamUnknownError
+    safeRead x = case reads $ Text.unpack x of
+        [] -> Nothing
+        [(y,_),_] -> Just y
+
+flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
+flattenAttrs attrs = map (\(name, content) ->
+                             ( name
+                             , Text.concat $ map uncontentify content)
+                             )
+                         attrs
+  where
+    uncontentify (ContentText t) = t
+    uncontentify _ = ""

source/Network/Xmpp/Stream.hs

@@ -12,7 +12,7 @@ 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.Text as Text
 import           Data.XML.Pickle
 import           Data.XML.Types
 import           Data.Void(Void)
@@ -20,6 +20,7 @@ import           Data.Void(Void)
 import           Network.Xmpp.Monad
 import           Network.Xmpp.Pickle
 import           Network.Xmpp.Types
+import           Network.Xmpp.Errors
 
 import           Text.XML.Stream.Elements
 import           Text.XML.Stream.Parse as XP
@@ -62,7 +63,7 @@ xmppStartStream :: XmppConMonad (Either StreamError ())
 xmppStartStream = runErrorT $ do
     state <- get
     -- Set the `to' attribute depending on the state of the connection.
-    let to = case sConnectionState state of
+    let from = case sConnectionState state of
                  XmppConnectionPlain -> if sJidWhenPlain state
                                         then sJid state else Nothing
                  XmppConnectionSecured -> sJid state
@@ -71,11 +72,13 @@ xmppStartStream = runErrorT $ do
         Just hostname -> lift $ do
             pushXmlDecl
             pushOpenElement $
-                pickleElem pickleOutStream ( to
-                                           , Just hostname
+                pickleElem xpStream ( "1.0"
+                                    , from
+                                    , Just (Jid Nothing hostname Nothing)
+                                    , Nothing
                                     , sPreferredLang state
                                     )
-    (lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream to
+    (lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream from
     modify (\s -> s { sFeatures = features
                     , sStreamLang = Just lt
                     , sStreamId = id
@@ -84,7 +87,7 @@ xmppStartStream = runErrorT $ do
            )
     return ()
 
--- Creates a new connection source (of Events) using the raw source (of bytes)
+-- Sets a new Event source using the raw source (of bytes)
 -- and calls xmppStartStream.
 xmppRestartStream :: XmppConMonad (Either StreamError ())
 xmppRestartStream = do
@@ -98,29 +101,30 @@ xmppRestartStream = do
 -- appropriate.
 -- TODO: from.
 xmppStream :: Maybe Jid -> StreamSink ( LangTag
-                                      , Maybe Text
+                                      , Maybe Jid
                                       , Maybe Text
                                       , ServerFeatures)
 xmppStream expectedTo = do
-    (langTag, from, id) <- xmppStreamHeader
+    (from, to, id, langTag) <- xmppStreamHeader
     features <- xmppStreamFeatures
     return (langTag, from, id, features)
   where
-    xmppStreamHeader :: StreamSink (LangTag, Maybe Text, Maybe Text)
+    xmppStreamHeader :: StreamSink (Maybe Jid, Maybe Jid, Maybe Text.Text, LangTag)
     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), ())
-            <- streamUnpickleElem pickleInStream =<< openElementFromEvents
-        unless (lname == "stream") $ throwError $ StreamNotStreamElement lname
-        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
-        let lang_ = maybe Nothing langTag lang
-        when (isNothing lang_) $ throwError $ StreamWrongLangTag lang
-        return (fromJust lang_, from, id)
+        el <- openElementFromEvents
+        case unpickleElem xpStream el of
+            Left _  -> throwError $ findStreamErrors el
+            Right r -> validateData r
+
+    validateData (_, _, _, _, Nothing) = throwError $ StreamWrongLangTag Nothing
+    validateData (ver, from, to, i, Just lang)
+      | ver /= "1.0" = throwError $ StreamWrongVersion (Just ver)
+      | to /= expectedTo = throwError $ StreamWrongTo (Text.pack . show <$> to)
+--      | lang /= expectedLang = throwError $ StreamWrongLangTag lang
+      | otherwise        = return (from, to, i, lang)
     xmppStreamFeatures :: StreamSink ServerFeatures
     xmppStreamFeatures = do
         e <- lift $ elements =$ CL.head
@@ -128,52 +132,18 @@ xmppStream expectedTo = do
             Nothing -> liftIO $ Ex.throwIO StreamConnectionError
             Just r -> streamUnpickleElem xpStreamFeatures r
 
--- Pickler for the stream element to be sent to the server. We follow what RFC
--- 6120 calls the "prefix-free canonicalization style".)
-pickleOutStream :: PU [Node] ( Maybe Jid -- from
-                             , Maybe Text -- to
-                             , Maybe LangTag -- 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" xpPrim)
-              (xpAttrImplied "to" xpId)
-              (xpAttr "version" xpId)
-              xpLangTag
-         )
-    )
 
--- 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
-                              )
-                            , ()
-                            )
-pickleInStream = xpElemWithName
+
+xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
+xpStream = xpElemAttrs
+    (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
     (xp5Tuple
-         (xpAttrImplied "from" xpId)
+         (xpAttr "version" xpId)
+         (xpAttrImplied "from" xpPrim)
+         (xpAttrImplied "to" xpPrim)
          (xpAttrImplied "id" xpId)
-         (xpAttrImplied "to" xpId)
-         (xpAttrImplied "version" xpId)
-         (xpAttrImplied (Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")) xpId)
+         xpLangTag
     )
-    xpUnit
 
 -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
 xpStreamFeatures :: PU [Node] ServerFeatures

source/Network/Xmpp/Types.hs

@@ -617,6 +617,8 @@ data XmppStreamError = XmppStreamError
     } deriving (Show, Eq)
 
 data StreamError = StreamError XmppStreamError
+                 | StreamUnknownError -- Something has gone wrong, but we don't
+                                      -- know what
                  | StreamNotStreamElement Text
                  | StreamInvalidStreamNamespace (Maybe Text)
                  | StreamInvalidStreamPrefix (Maybe Text)
@@ -757,7 +759,7 @@ data XmppConnection = XmppConnection
                                                -- 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
+               , sFrom            :: Maybe Jid  -- From as specified by the
                                                 -- server in the stream
                                                 -- element's `from' attribute.
                }