asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Re-add `findStreamErrors' functionality 

The library should now generate the proper stream errors again, in
case of received stream open element problem.

The return type of streamS has been modified so that the validation
can be performed in startStream instead, and without exceptions. This
will also help enable implementation of logging later.

The Errors module has been removed.
master
Jon Kristensen 13 years ago
parent
c34982dba9
commit
a1d027940e
2 changed files with 102 additions and 50 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 14
      source/Network/Xmpp/Errors.hs
  2. 138
      source/Network/Xmpp/Stream.hs

14
source/Network/Xmpp/Errors.hs
Unescape View File

@ -1,14 +0,0 @@
{-# 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

138
source/Network/Xmpp/Stream.hs
Unescape View File

@ -24,13 +24,14 @@ import Network.Xmpp.Connection
import Network.Xmpp.Errors import Network.Xmpp.Errors
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Marshal
import Text.Xml.Stream.Elements import Text.Xml.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
-- Unpickles and returns a stream element. Throws a StreamXmlError on failure. -- Unpickles and returns a stream element.
streamUnpickleElem :: PU [Node] a streamUnpickleElem :: PU [Node] a
-> Element -> Element
-> StreamSink a -> StreamSink a
@ -61,34 +62,98 @@ openElementFromEvents = do
Just (EventBeginElement name attrs) -> return $ Element name attrs [] Just (EventBeginElement name attrs) -> return $ Element name attrs []
_ -> throwError $ StreamOtherFailure _ -> throwError $ StreamOtherFailure
-- Sends the initial stream:stream element and pulls the server features. -- Sends the initial stream:stream element and pulls the server features. If the
-- server responds in a way that is invalid, an appropriate stream error will be
-- generated, the connection to the server will be closed, and a StreamFilure
-- will be produced.
startStream :: StateT Connection_ IO (Either StreamFailure ()) startStream :: StateT Connection_ IO (Either StreamFailure ())
startStream = runErrorT $ do startStream = runErrorT $ do
state <- get state <- lift $ get
-- Set the `to' attribute depending on the state of the connection. con <- liftIO $ mkConnection state
let from = case sConnectionState state of -- Set the `from' (which is also the expected to) attribute depending on the
-- state of the connection.
let expectedTo = case sConnectionState state of
ConnectionPlain -> if sJidWhenPlain state ConnectionPlain -> if sJidWhenPlain state
then sJid state else Nothing then sJid state else Nothing
ConnectionSecured -> sJid state ConnectionSecured -> sJid state
case sHostname state of case sHostname state of
Nothing -> throwError StreamOtherFailure Nothing -> throwError StreamOtherFailure -- TODO: When does this happen?
Just hostname -> lift $ do Just hostname -> lift $ do
pushXmlDecl pushXmlDecl
pushOpenElement $ pushOpenElement $
pickleElem xpStream ( "1.0" pickleElem xpStream ( "1.0"
, from , expectedTo
, Just (Jid Nothing hostname Nothing) , Just (Jid Nothing hostname Nothing)
, Nothing , Nothing
, sPreferredLang state , sPreferredLang state
) )
(lt, from, id, features) <- ErrorT . runEventsSink $ runErrorT $ response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo
streamS from case response of
modify (\s -> s{ sFeatures = features -- Successful unpickling of stream element.
, sStreamLang = Just lt Right (ver, from, to, id, lt, features)
, sStreamId = id | (unpack $ fromJust id) /= "1.0" ->
, sFrom = from closeStreamWithError con StreamUnsupportedVersion Nothing
} ) | lt == Nothing ->
return () closeStreamWithError con StreamInvalidXml Nothing
-- 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 $ sHostname state) Nothing)) ->
closeStreamWithError con StreamInvalidFrom Nothing
| to /= expectedTo ->
closeStreamWithError con StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable?
| otherwise -> do
modify (\s -> s{ sFeatures = features
, sStreamLang = lt
, sStreamId = id
, sFrom = from
} )
return ()
-- Unpickling failed - we investigate the element.
Left (Element name attrs children)
| (nameLocalName name /= "stream") ->
closeStreamWithError con StreamInvalidXml Nothing
| (nameNamespace name /= Just "http://etherx.jabber.org/streams") ->
closeStreamWithError con StreamInvalidNamespace Nothing
| (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") ->
closeStreamWithError con StreamBadNamespacePrefix Nothing
| otherwise -> ErrorT $ checkchildren con (flattenAttrs attrs)
where
-- closeStreamWithError :: MonadIO m => Connection -> StreamErrorCondition ->
-- Maybe Element -> ErrorT StreamFailure m ()
closeStreamWithError con sec el = do
liftIO $ do
withConnection (pushElement . pickleElem xpStreamError $
StreamErrorInfo sec Nothing el) con
closeStreams con
throwError StreamOtherFailure
checkchildren con 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 con
StreamBadNamespacePrefix Nothing
| Nothing == ver' ->
runErrorT $ closeStreamWithError con
StreamUnsupportedVersion Nothing
| Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) ->
runErrorT $ closeStreamWithError con
StreamInvalidXml Nothing
| otherwise ->
runErrorT $ closeStreamWithError con
StreamBadFormat Nothing
safeRead x = case reads $ Text.unpack x of
[] -> Nothing
[(y,_),_] -> Just y
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
flattenAttrs attrs = Prelude.map (\(name, content) ->
( name
, Text.concat $ Prelude.map uncontentify content)
)
attrs
where
uncontentify (ContentText t) = t
uncontentify _ = ""
-- Sets a new Event source using the raw source (of bytes) -- Sets a new Event source using the raw source (of bytes)
-- and calls xmppStartStream. -- and calls xmppStartStream.
@ -107,42 +172,43 @@ restartStream = do
else yield bs >> loopRead read else yield bs >> loopRead read
-- Reads the (partial) stream:stream and the server features from the stream. -- Reads the (partial) stream:stream and the server features from the stream.
-- Also validates the stream element's attributes and throws an error if -- Returns the (unvalidated) stream attributes, the unparsed element, or
-- appropriate. -- throwError throws a `StreamOtherFailure' (if something other than an element
-- was encountered at first, or if something other than stream features was
-- encountered second).
-- TODO: from. -- TODO: from.
streamS :: Maybe Jid -> StreamSink ( LangTag streamS :: Maybe Jid -> StreamSink (Either Element ( Text
, Maybe Jid , Maybe Jid
, Maybe Text , Maybe Jid
, ServerFeatures) , Maybe Text
, Maybe LangTag
, ServerFeatures ))
streamS expectedTo = do streamS expectedTo = do
(from, to, id, langTag) <- xmppStreamHeader header <- xmppStreamHeader
features <- xmppStreamFeatures case header of
return (langTag, from, id, features) Right (version, from, to, id, langTag) -> do
features <- xmppStreamFeatures
return $ Right (version, from, to, id, langTag, features)
Left el -> return $ Left el
where where
xmppStreamHeader :: StreamSink (Maybe Jid, Maybe Jid, Maybe Text.Text, LangTag) xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))
xmppStreamHeader = do xmppStreamHeader = do
lift throwOutJunk lift throwOutJunk
-- Get the stream:stream element (or whatever it is) from the server, -- Get the stream:stream element (or whatever it is) from the server,
-- and validate what we get. -- and validate what we get.
el <- openElementFromEvents el <- openElementFromEvents -- May throw `StreamOtherFailure' if an
-- element is not received
case unpickleElem xpStream el of case unpickleElem xpStream el of
Left _ -> throwError StreamOtherFailure -- TODO: findStreamErrors el Left _ -> return $ Left el
Right r -> validateData r Right r -> return $ Right r
validateData (_, _, _, _, Nothing) = throwError StreamOtherFailure -- StreamWrongLangTag Nothing
validateData (ver, from, to, i, Just lang)
| ver /= "1.0" = throwError StreamOtherFailure -- StreamWrongVersion (Just ver)
| isJust to && to /= expectedTo = throwError StreamOtherFailure -- StreamWrongTo (Text.pack . show <$> to)
| otherwise = return (from, to, i, lang)
xmppStreamFeatures :: StreamSink ServerFeatures xmppStreamFeatures :: StreamSink ServerFeatures
xmppStreamFeatures = do xmppStreamFeatures = do
e <- lift $ elements =$ CL.head e <- lift $ elements =$ CL.head
case e of case e of
Nothing -> liftIO $ Ex.throwIO StreamOtherFailure Nothing -> throwError StreamOtherFailure
Just r -> streamUnpickleElem xpStreamFeatures r Just r -> streamUnpickleElem xpStreamFeatures r
xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag) xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
xpStream = xpElemAttrs xpStream = xpElemAttrs
(Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))

Write Preview
Loading…
Cancel
Save