From da2745d00fd2d5c28d3c6464487b66e040ae5322 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 1 Mar 2013 23:03:17 +0100 Subject: [PATCH 1/3] fix stream feature pickler a name space was missing --- source/Network/Xmpp/Marshal.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 8d47217..1360e56 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -247,7 +247,7 @@ xpStream = xpElemAttrs -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. xpStreamFeatures :: PU [Node] StreamFeatures -xpStreamFeatures = xpWrap +xpStreamFeatures = ("xpStreamFeatures","") xpWrap (\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest) (\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest)) (xpElemNodes @@ -264,10 +264,11 @@ xpStreamFeatures = xpWrap ) where pickleTlsFeature :: PU [Node] Bool - pickleTlsFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" - (xpElemExists "required") + pickleTlsFeature = ("pickleTlsFeature", "") + xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + (xpElemExists "{urn:ietf:params:xml:ns:xmpp-tls}required") pickleSaslFeature :: PU [Node] [Text] - pickleSaslFeature = xpElemNodes - "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + pickleSaslFeature = ("pickleSaslFeature", "") + xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" (xpAll $ xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId)) From 7c2e8b7a0bd0435bb40f1e2a37dedc43b168d50e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 4 Mar 2013 13:43:23 +0100 Subject: [PATCH 2/3] replace nested TMVar usage with StateT Stream --- source/Network/Xmpp/Stream.hs | 44 ++++++++++++++++++----------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 0bb5098..e885d19 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -94,7 +94,6 @@ startStream :: StateT Stream IO (Either XmppFailure ()) startStream = runErrorT $ do liftIO $ debugM "Pontarius.Xmpp" "starting stream" state <- lift $ get - stream <- liftIO $ mkStream state -- Set the `from' (which is also the expected to) attribute depending on the -- state of the stream. let expectedTo = case (streamState state, toJid $ streamConfiguration state) of @@ -120,17 +119,17 @@ startStream = runErrorT $ do -- Successful unpickling of stream element. Right (Right (ver, from, to, id, lt, features)) | (Text.unpack ver) /= "1.0" -> - closeStreamWithError stream StreamUnsupportedVersion Nothing - "Unknown stream version" + closeStreamWithError StreamUnsupportedVersion Nothing + "Unknown version" | lt == Nothing -> - closeStreamWithError stream StreamInvalidXml Nothing + closeStreamWithError StreamInvalidXml Nothing "stream has no language tag" -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? | isJust from && (from /= Just (Jid Nothing (fromJust $ streamHostname state) Nothing)) -> - closeStreamWithError stream StreamInvalidFrom Nothing + closeStreamWithError StreamInvalidFrom Nothing "stream from is invalid" | to /= expectedTo -> - closeStreamWithError stream StreamUndefinedCondition (Just $ Element "invalid-to" [] []) + closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] []) "stream to invalid"-- TODO: Suitable? | otherwise -> do modify (\s -> s{ streamFeatures = features @@ -142,42 +141,43 @@ startStream = runErrorT $ do -- Unpickling failed - we investigate the element. Right (Left (Element name attrs children)) | (nameLocalName name /= "stream") -> - closeStreamWithError stream StreamInvalidXml Nothing + closeStreamWithError StreamInvalidXml Nothing "Root element is not stream" | (nameNamespace name /= Just "http://etherx.jabber.org/streams") -> - closeStreamWithError stream StreamInvalidNamespace Nothing + closeStreamWithError StreamInvalidNamespace Nothing "Wrong root element name space" | (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") -> - closeStreamWithError stream StreamBadNamespacePrefix Nothing + closeStreamWithError StreamBadNamespacePrefix Nothing "Root name prefix set and not stream" - | otherwise -> ErrorT $ checkchildren stream (flattenAttrs attrs) + | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) where -- closeStreamWithError :: MonadIO m => TMVar Stream -> StreamErrorCondition -> -- Maybe Element -> ErrorT XmppFailure m () - closeStreamWithError stream sec el msg = do - liftIO $ do - withStream (pushElement . pickleElem xpStreamError $ - StreamErrorInfo sec Nothing el) stream - closeStreams stream + closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String + -> ErrorT XmppFailure (StateT Stream IO) () + closeStreamWithError sec el msg = do + lift . pushElement . pickleElem xpStreamError + $ StreamErrorInfo sec Nothing el + lift $ closeStreams' throwError $ XmppOtherFailure msg - checkchildren stream children = + checkchildren children = let to' = lookup "to" children ver' = lookup "version" children xl = lookup xmlLang children in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') -> - runErrorT $ closeStreamWithError stream + runErrorT $ closeStreamWithError StreamBadNamespacePrefix Nothing "stream to not a valid JID" | Nothing == ver' -> - runErrorT $ closeStreamWithError stream + runErrorT $ closeStreamWithError StreamUnsupportedVersion Nothing "stream no version" | Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) -> - runErrorT $ closeStreamWithError stream + runErrorT $ closeStreamWithError StreamInvalidXml Nothing "stream no language tag" | otherwise -> - runErrorT $ closeStreamWithError stream + runErrorT $ closeStreamWithError StreamBadFormat Nothing "" safeRead x = case reads $ Text.unpack x of @@ -264,7 +264,9 @@ openStream address port hostname config = do -- close the connection. Any remaining elements from the server are returned. -- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError. closeStreams :: TMVar Stream -> IO (Either XmppFailure [Element]) -closeStreams = withStream $ do +closeStreams = withStream closeStreams' + +closeStreams' = do send <- gets (streamSend . streamHandle) cc <- gets (streamClose . streamHandle) liftIO $ send "" From bec4490efba04f04d15b046192eabb06b6704b4a Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 4 Mar 2013 15:14:36 +0100 Subject: [PATCH 3/3] pretty print unpickle errors in error messages --- source/Network/Xmpp/Stream.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index e885d19..7ce9ba7 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -60,7 +60,8 @@ streamUnpickleElem :: PU [Node] a -> StreamSink a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ XmppOtherFailure "Unpickle error" + Left l -> throwError $ XmppOtherFailure ("Unpickle error" + ++ ppUnpickleError l) -- TODO: Log: StreamXmlError (show l) Right r -> return r @@ -356,8 +357,9 @@ pullUnpickle p = do Right elem' -> do let res = unpickleElem p elem' case res of - Left e -> return . Left $ XmppOtherFailure - "pullUnpickle: unpickle failed" -- TODO: Log + Left e -> return . Left . XmppOtherFailure $ + "pullUnpickle: unpickle failed" ++ ppUnpickleError e + -- TODO: Log Right r -> return $ Right r -- | Pulls a stanza (or stream error) from the stream.