From 786b8cd4870d6b19c7b2b46ae648e8f1095ddd82 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 24 Jun 2012 16:08:58 +0200 Subject: [PATCH] unsplit picklers --- source/Network/Xmpp.hs | 39 ++++++-------- source/Network/Xmpp/Errors.hs | 49 ++++++++++++++++++ source/Network/Xmpp/Stream.hs | 98 ++++++++++++----------------------- source/Network/Xmpp/Types.hs | 6 ++- 4 files changed, 102 insertions(+), 90 deletions(-) create mode 100644 source/Network/Xmpp/Errors.hs diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 278aa4d..12495ae 100644 --- a/source/Network/Xmpp.hs +++ b/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 diff --git a/source/Network/Xmpp/Errors.hs b/source/Network/Xmpp/Errors.hs new file mode 100644 index 0000000..0172b6d --- /dev/null +++ b/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 _ = "" \ No newline at end of file diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 5f4c262..1c64db0 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/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 - , sPreferredLang state - ) - (lt, from, id, features) <- ErrorT . pullToSink $ runErrorT $ xmppStream to + pickleElem xpStream ( "1.0" + , from + , Just (Jid Nothing hostname Nothing) + , Nothing + , sPreferredLang state + ) + (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,53 +132,19 @@ 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 xpStreamFeatures = xpWrap diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index ebb33e6..76d7d36 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -617,12 +617,14 @@ 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) | StreamWrongTo (Maybe Text) | StreamWrongVersion (Maybe Text) - | StreamWrongLangTag (Maybe Text) + | StreamWrongLangTag (Maybe Text) | StreamXMLError String -- If stream pickling goes wrong. | StreamStreamEnd -- received closing stream tag | StreamConnectionError @@ -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. }