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

Make the stream failure types more intuitive and clear 

StreamError has been renamed to StreamFailure, as it's neither an
error or an exception, and since the term "stream error" is ambigous
(it can also refer to the stream error element on the XMPP stream).
Furthermore, XmppTLSError has been renamed to TLSFailure.

The data types related to the above mentioned failures are now
exported.

We do no longer clutter the API with detailed error conditions such as
StreamNotStreamElement. These kinds of conditions are such rare
occurances, and details about them are better suited in the logging
system (to be implemented soon).

Stream failures can occur either when a `stream:error' first-level
XML element is encountered, or if something unexpected happens in the
stream. Currently, `StreamErrorFailure', `StreamEndFailure', and
`StreamOtherFailure' are defined for these purposes, but additional
exceptions can be added if that would be helpful for the developers.

TLSFailure is moved to Types.hs and is now exported.

Also temporarily removed findStreamErrors.
master
Jon Kristensen 13 years ago
parent
b096b2f1b3
commit
6c7aa54ea4
13 changed files with 97 additions and 131 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. 8
      source/Network/Xmpp.hs
  2. 4
      source/Network/Xmpp/Bind.hs
  3. 2
      source/Network/Xmpp/Concurrent/Monad.hs
  4. 6
      source/Network/Xmpp/Concurrent/Threads.hs
  5. 2
      source/Network/Xmpp/Concurrent/Types.hs
  6. 32
      source/Network/Xmpp/Connection.hs
  7. 35
      source/Network/Xmpp/Errors.hs
  8. 8
      source/Network/Xmpp/Marshal.hs
  9. 2
      source/Network/Xmpp/Sasl/Types.hs
  10. 28
      source/Network/Xmpp/Session.hs
  11. 22
      source/Network/Xmpp/Stream.hs
  12. 22
      source/Network/Xmpp/TLS.hs
  13. 51
      source/Network/Xmpp/Types.hs

8
source/Network/Xmpp.hs
Unescape View File

@ -19,10 +19,6 @@
-- Pontarius is an XMPP client library, implementing the core capabilities of -- Pontarius is an XMPP client library, implementing the core capabilities of
-- XMPP (RFC 6120): setup and teardown of XML streams, channel encryption, -- XMPP (RFC 6120): setup and teardown of XML streams, channel encryption,
-- authentication, error handling, and communication primitives for messaging. -- authentication, error handling, and communication primitives for messaging.
--
-- Note that we are not recommending anyone to use Pontarius XMPP at this time
-- as it's still in an experimental stage and will have its API and data types
-- modified frequently.
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
@ -149,6 +145,10 @@ module Network.Xmpp
, LangTag(..) , LangTag(..)
, exampleParams , exampleParams
, PortID(..) , PortID(..)
, StreamFailure(..)
, StreamErrorInfo(..)
, StreamErrorCondition(..)
, TLSFailure(..)
) where ) where

4
source/Network/Xmpp/Bind.hs
Unescape View File

@ -34,8 +34,8 @@ xmppBind rsrc c = do
jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer
, Right jid <- unpickleElem xpJid b , Right jid <- unpickleElem xpJid b
-> return jid -> return jid
| otherwise -> throw $ StreamXMLError | otherwise -> throw StreamOtherFailure
("Bind couldn't unpickle JID from " ++ show answer) -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer)
withConnection (modify $ \s -> s{sJid = Just jid}) c withConnection (modify $ \s -> s{sJid = Just jid}) c
return jid return jid
where where

2
source/Network/Xmpp/Concurrent/Monad.hs
Unescape View File

@ -71,7 +71,7 @@ modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f
writeTVar var (f x) writeTVar var (f x)
-- | Sets the handler to be executed when the server connection is closed. -- | Sets the handler to be executed when the server connection is closed.
setConnectionClosedHandler :: (StreamError -> Context -> IO ()) -> Context -> IO () setConnectionClosedHandler :: (StreamFailure -> Context -> IO ()) -> Context -> IO ()
setConnectionClosedHandler eh session = do setConnectionClosedHandler eh session = do
modifyHandlers (\s -> s{connectionClosedHandler = modifyHandlers (\s -> s{connectionClosedHandler =
\e -> eh e session}) session \e -> eh e session}) session

6
source/Network/Xmpp/Concurrent/Threads.hs
Unescape View File

@ -23,7 +23,7 @@ import GHC.IO (unsafeUnmask)
-- Worker to read stanzas from the stream and concurrently distribute them to -- Worker to read stanzas from the stream and concurrently distribute them to
-- all listener threads. -- all listener threads.
readWorker :: (Stanza -> IO ()) readWorker :: (Stanza -> IO ())
-> (StreamError -> IO ()) -> (StreamFailure -> IO ())
-> TMVar Connection -> TMVar Connection
-> IO a -> IO a
readWorker onStanza onConnectionClosed stateRef = readWorker onStanza onConnectionClosed stateRef =
@ -43,7 +43,7 @@ readWorker onStanza onConnectionClosed stateRef =
[ Ex.Handler $ \(Interrupt t) -> do [ Ex.Handler $ \(Interrupt t) -> do
void $ handleInterrupts [t] void $ handleInterrupts [t]
return Nothing return Nothing
, Ex.Handler $ \(e :: StreamError) -> do , Ex.Handler $ \(e :: StreamFailure) -> do
onConnectionClosed e onConnectionClosed e
return Nothing return Nothing
] ]
@ -96,7 +96,7 @@ startThreadsWith stanzaHandler eh con = do
_ <- forM threads killThread _ <- forM threads killThread
return () return ()
-- Call the connection closed handlers. -- Call the connection closed handlers.
noCon :: TVar EventHandlers -> StreamError -> IO () noCon :: TVar EventHandlers -> StreamFailure -> IO ()
noCon h e = do noCon h e = do
hands <- atomically $ readTVar h hands <- atomically $ readTVar h
_ <- forkIO $ connectionClosedHandler hands e _ <- forkIO $ connectionClosedHandler hands e

2
source/Network/Xmpp/Concurrent/Types.hs
Unescape View File

@ -15,7 +15,7 @@ import Network.Xmpp.Types
-- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is
-- closed. -- closed.
data EventHandlers = EventHandlers data EventHandlers = EventHandlers
{ connectionClosedHandler :: StreamError -> IO () { connectionClosedHandler :: StreamFailure -> IO ()
} }
-- | Xmpp Context object -- | Xmpp Context object

32
source/Network/Xmpp/Connection.hs
Unescape View File

@ -78,14 +78,14 @@ pullElement = do
Ex.catches (do Ex.catches (do
e <- runEventsSink (elements =$ await) e <- runEventsSink (elements =$ await)
case e of case e of
Nothing -> liftIO $ Ex.throwIO StreamConnectionError Nothing -> liftIO $ Ex.throwIO StreamOtherFailure
Just r -> return r Just r -> return r
) )
[ Ex.Handler (\StreamEnd -> Ex.throwIO StreamStreamEnd) [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamEndFailure)
, Ex.Handler (\(InvalidXmppXml s) , Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag
-> liftIO . Ex.throwIO $ StreamXMLError s) -> liftIO . Ex.throwIO $ StreamOtherFailure) -- TODO: Log: s
, Ex.Handler $ \(e :: InvalidEventStream) , Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception
-> liftIO . Ex.throwIO $ StreamXMLError (show e) -> liftIO . Ex.throwIO $ StreamOtherFailure -- TODO: Log: (show e)
] ]
-- Pulls an element and unpickles it. -- Pulls an element and unpickles it.
@ -93,7 +93,7 @@ pullUnpickle :: PU [Node] a -> StateT Connection_ IO a
pullUnpickle p = do pullUnpickle p = do
res <- unpickleElem p <$> pullElement res <- unpickleElem p <$> pullElement
case res of case res of
Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e) Left e -> liftIO $ Ex.throwIO e
Right r -> return r Right r -> return r
-- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream -- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream
@ -102,7 +102,7 @@ pullStanza :: Connection -> IO Stanza
pullStanza = withConnection' $ do pullStanza = withConnection' $ do
res <- pullUnpickle xpStreamStanza res <- pullUnpickle xpStreamStanza
case res of case res of
Left e -> liftIO . Ex.throwIO $ StreamError e Left e -> liftIO . Ex.throwIO $ StreamErrorFailure e
Right r -> return r Right r -> return r
-- Performs the given IO operation, catches any errors and re-throws everything -- Performs the given IO operation, catches any errors and re-throws everything
@ -121,7 +121,7 @@ xmppNoConnection :: Connection_
xmppNoConnection = Connection_ xmppNoConnection = Connection_
{ cHand = Hand { cSend = \_ -> return False { cHand = Hand { cSend = \_ -> return False
, cRecv = \_ -> Ex.throwIO , cRecv = \_ -> Ex.throwIO
$ StreamConnectionError $ StreamOtherFailure
, cFlush = return () , cFlush = return ()
, cClose = return () , cClose = return ()
} }
@ -139,7 +139,7 @@ xmppNoConnection = Connection_
} }
where where
zeroSource :: Source IO output zeroSource :: Source IO output
zeroSource = liftIO . Ex.throwIO $ StreamConnectionError zeroSource = liftIO . Ex.throwIO $ StreamOtherFailure
-- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and -- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and
-- updates the XmppConMonad Connection_ state. -- updates the XmppConMonad Connection_ state.
@ -205,12 +205,12 @@ pushIQ' iqID to tp lang body con = do
IQResultS r -> do IQResultS r -> do
unless unless
(iqID == iqResultID r) . liftIO . Ex.throwIO $ (iqID == iqResultID r) . liftIO . Ex.throwIO $
StreamXMLError StreamOtherFailure
("In sendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++
show (iqResultID r) ++ " .") -- " /= " ++ show (iqResultID r) ++ " .")
return $ Right r return $ Right r
_ -> liftIO . Ex.throwIO . StreamXMLError $ _ -> liftIO $ Ex.throwIO StreamOtherFailure
"sendIQ': unexpected stanza type " -- TODO: Log: "sendIQ': unexpected stanza type "
-- | Send "</stream:stream>" and wait for the server to finish processing and to -- | Send "</stream:stream>" and wait for the server to finish processing and to
-- close the connection. Any remaining elements from the server and whether or -- close the connection. Any remaining elements from the server and whether or
@ -232,7 +232,7 @@ closeStreams = withConnection $ do
collectElems es = do collectElems es = do
result <- Ex.try pullElement result <- Ex.try pullElement
case result of case result of
Left StreamStreamEnd -> return (es, True) Left StreamEndFailure -> return (es, True)
Left _ -> return (es, False) Left _ -> return (es, False)
Right e -> collectElems (e:es) Right e -> collectElems (e:es)

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

@ -12,38 +12,3 @@ import Network.Xmpp.Types
import Network.Xmpp.Pickle 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 _ = ""

8
source/Network/Xmpp/Marshal.hs
Unescape View File

@ -14,7 +14,7 @@ import Data.XML.Types
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
import Network.Xmpp.Types import Network.Xmpp.Types
xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza)
xpStreamStanza = xpEither xpStreamError xpStanza xpStreamStanza = xpEither xpStreamError xpStanza
xpStanza :: PU [Node] Stanza xpStanza :: PU [Node] Stanza
@ -182,10 +182,10 @@ xpIQError = xpWrap
(xp2Tuple xpStanzaError (xpOption xpElemVerbatim)) (xp2Tuple xpStanzaError (xpOption xpElemVerbatim))
) )
xpStreamError :: PU [Node] XmppStreamError xpStreamError :: PU [Node] StreamErrorInfo
xpStreamError = xpWrap xpStreamError = xpWrap
(\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) (\((cond,() ,()), txt, el) -> StreamErrorInfo cond txt el)
(\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) (\(StreamErrorInfo cond txt el) ->((cond,() ,()), txt, el))
(xpElemNodes (xpElemNodes
(Name (Name
"error" "error"

2
source/Network/Xmpp/Sasl/Types.hs
Unescape View File

@ -13,7 +13,7 @@ data AuthError = AuthXmlError
| AuthChallengeError | AuthChallengeError
| AuthServerAuthError -- ^ The server failed to authenticate | AuthServerAuthError -- ^ The server failed to authenticate
-- itself -- itself
| AuthStreamError StreamError -- ^ Stream error on stream restart | AuthStreamError StreamFailure -- ^ Stream error on stream restart
-- TODO: Rename AuthConnectionError? -- TODO: Rename AuthConnectionError?
| AuthConnectionError -- ^ Connection is closed | AuthConnectionError -- ^ Connection is closed
| AuthError -- General instance used for the Error instance | AuthError -- General instance used for the Error instance

28
source/Network/Xmpp/Session.hs
Unescape View File

@ -61,7 +61,7 @@ simpleConnect host port hostname username password resource = do
-- | Connect to host with given address. -- | Connect to host with given address.
connectTcp :: HostName -> PortID -> Text -> IO (Either StreamError Connection) connectTcp :: HostName -> PortID -> Text -> IO (Either StreamFailure Connection)
connectTcp address port hostname = do connectTcp address port hostname = do
con <- connectTcpRaw address port hostname con <- connectTcpRaw address port hostname
result <- withConnection startStream con result <- withConnection startStream con
@ -73,20 +73,20 @@ connectTcp address port hostname = do
return $ Left e return $ Left e
Right () -> return $ Right con Right () -> return $ Right con
where where
toError (StreamNotStreamElement _name) = -- toError (StreamNotStreamElement _name) =
XmppStreamError StreamInvalidXml Nothing Nothing -- XmppStreamFailure StreamInvalidXml Nothing Nothing
toError (StreamInvalidStreamNamespace _ns) = -- toError (StreamInvalidStreamNamespace _ns) =
XmppStreamError StreamInvalidNamespace Nothing Nothing -- XmppStreamFailure StreamInvalidNamespace Nothing Nothing
toError (StreamInvalidStreamPrefix _prefix) = -- toError (StreamInvalidStreamPrefix _prefix) =
XmppStreamError StreamBadNamespacePrefix Nothing Nothing -- XmppStreamFailure StreamBadNamespacePrefix Nothing Nothing
toError (StreamWrongVersion _ver) = -- toError (StreamWrongVersion _ver) =
XmppStreamError StreamUnsupportedVersion Nothing Nothing -- XmppStreamFailure StreamUnsupportedVersion Nothing Nothing
toError (StreamWrongLangTag _) = -- toError (StreamWrongLangTag _) =
XmppStreamError StreamInvalidXml Nothing Nothing -- XmppStreamFailure StreamInvalidXml Nothing Nothing
toError StreamUnknownError = -- toError StreamUnknownError =
XmppStreamError StreamBadFormat Nothing Nothing -- XmppStreamFailure StreamBadFormat Nothing Nothing
-- TODO: Catch remaining xmppStartStream errors. -- TODO: Catch remaining xmppStartStream errors.
toError _ = XmppStreamError StreamBadFormat Nothing Nothing toError _ = StreamErrorInfo StreamBadFormat Nothing Nothing
sessionXML :: Element sessionXML :: Element
sessionXML = pickleElem sessionXML = pickleElem

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

@ -36,12 +36,12 @@ streamUnpickleElem :: PU [Node] a
-> StreamSink a -> StreamSink a
streamUnpickleElem p x = do streamUnpickleElem p x = do
case unpickleElem p x of case unpickleElem p x of
Left l -> throwError $ StreamXMLError (show l) Left l -> throwError $ StreamOtherFailure -- TODO: Log: StreamXMLError (show l)
Right r -> return r Right r -> return r
-- This is the conduit sink that handles the stream XML events. We extend it -- This is the conduit sink that handles the stream XML events. We extend it
-- with ErrorT capabilities. -- with ErrorT capabilities.
type StreamSink a = ErrorT StreamError (Pipe Event Event Void () IO) a type StreamSink a = ErrorT StreamFailure (Pipe Event Event Void () IO) a
-- Discards all events before the first EventBeginElement. -- Discards all events before the first EventBeginElement.
throwOutJunk :: Monad m => Sink Event m () throwOutJunk :: Monad m => Sink Event m ()
@ -59,10 +59,10 @@ openElementFromEvents = do
hd <- lift CL.head hd <- lift CL.head
case hd of case hd of
Just (EventBeginElement name attrs) -> return $ Element name attrs [] Just (EventBeginElement name attrs) -> return $ Element name attrs []
_ -> throwError $ StreamConnectionError _ -> throwError $ StreamOtherFailure
-- Sends the initial stream:stream element and pulls the server features. -- Sends the initial stream:stream element and pulls the server features.
startStream :: StateT Connection_ IO (Either StreamError ()) startStream :: StateT Connection_ IO (Either StreamFailure ())
startStream = runErrorT $ do startStream = runErrorT $ do
state <- get state <- get
-- Set the `to' attribute depending on the state of the connection. -- Set the `to' attribute depending on the state of the connection.
@ -71,7 +71,7 @@ startStream = runErrorT $ do
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 StreamConnectionError Nothing -> throwError StreamOtherFailure
Just hostname -> lift $ do Just hostname -> lift $ do
pushXmlDecl pushXmlDecl
pushOpenElement $ pushOpenElement $
@ -92,7 +92,7 @@ startStream = runErrorT $ do
-- 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.
restartStream :: StateT Connection_ IO (Either StreamError ()) restartStream :: StateT Connection_ IO (Either StreamFailure ())
restartStream = do restartStream = do
raw <- gets (cRecv . cHand) raw <- gets (cRecv . cHand)
let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def)
@ -126,19 +126,19 @@ streamS expectedTo = do
-- and validate what we get. -- and validate what we get.
el <- openElementFromEvents el <- openElementFromEvents
case unpickleElem xpStream el of case unpickleElem xpStream el of
Left _ -> throwError $ findStreamErrors el Left _ -> throwError StreamOtherFailure -- TODO: findStreamErrors el
Right r -> validateData r Right r -> validateData r
validateData (_, _, _, _, Nothing) = throwError $ StreamWrongLangTag Nothing validateData (_, _, _, _, Nothing) = throwError StreamOtherFailure -- StreamWrongLangTag Nothing
validateData (ver, from, to, i, Just lang) validateData (ver, from, to, i, Just lang)
| ver /= "1.0" = throwError $ StreamWrongVersion (Just ver) | ver /= "1.0" = throwError StreamOtherFailure -- StreamWrongVersion (Just ver)
| isJust to && to /= expectedTo = throwError $ StreamWrongTo (Text.pack . show <$> to) | isJust to && to /= expectedTo = throwError StreamOtherFailure -- StreamWrongTo (Text.pack . show <$> to)
| otherwise = return (from, to, i, lang) | 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 StreamConnectionError Nothing -> liftIO $ Ex.throwIO StreamOtherFailure
Just r -> streamUnpickleElem xpStreamFeatures r Just r -> streamUnpickleElem xpStreamFeatures r

22
source/Network/Xmpp/TLS.hs
Unescape View File

@ -72,21 +72,9 @@ exampleParams = TLS.defaultParamsClient
return TLS.CertificateUsageAccept return TLS.CertificateUsageAccept
} }
-- | Error conditions that may arise during TLS negotiation.
data XmppTLSError = TLSError TLSError
| TLSNoServerSupport
| TLSNoConnection
| TLSConnectionSecured -- ^ Connection already secured
| TLSStreamError StreamError
| XmppTLSError -- General instance used for the Error instance
deriving (Show, Eq, Typeable)
instance Error XmppTLSError where
noMsg = XmppTLSError
-- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and -- Pushes "<starttls/>, waits for "<proceed/>", performs the TLS handshake, and
-- restarts the stream. May throw errors. -- restarts the stream.
startTLS :: TLS.TLSParams -> Connection -> IO (Either XmppTLSError ()) startTLS :: TLS.TLSParams -> Connection -> IO (Either TLSFailure ())
startTLS params con = Ex.handle (return . Left . TLSError) startTLS params con = Ex.handle (return . Left . TLSError)
. flip withConnection con . flip withConnection con
. runErrorT $ do . runErrorT $ do
@ -103,10 +91,10 @@ startTLS params con = Ex.handle (return . Left . TLSError)
case answer of case answer of
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return ()
Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ -> Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ ->
lift . Ex.throwIO $ StreamConnectionError lift $ Ex.throwIO StreamOtherFailure
-- TODO: find something more suitable -- TODO: find something more suitable
e -> lift . Ex.throwIO . StreamXMLError $ e -> lift $ Ex.throwIO StreamOtherFailure
"Unexpected element: " ++ ppElement e -- TODO: Log: "Unexpected element: " ++ ppElement e
(raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con) (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con)
let newHand = Hand { cSend = catchPush . psh let newHand = Hand { cSend = catchPush . psh
, cRecv = read , cRecv = read

51
source/Network/Xmpp/Types.hs
Unescape View File

@ -28,7 +28,7 @@ module Network.Xmpp.Types
, StanzaErrorCondition(..) , StanzaErrorCondition(..)
, StanzaErrorType(..) , StanzaErrorType(..)
, StanzaId(..) , StanzaId(..)
, StreamError(..) , StreamFailure(..)
, StreamErrorCondition(..) , StreamErrorCondition(..)
, Version(..) , Version(..)
, HandleLike(..) , HandleLike(..)
@ -38,8 +38,9 @@ module Network.Xmpp.Types
, withConnection' , withConnection'
, mkConnection , mkConnection
, ConnectionState(..) , ConnectionState(..)
, XmppStreamError(..) , StreamErrorInfo(..)
, langTag , langTag
, TLSFailure(..)
, module Network.Xmpp.Jid , module Network.Xmpp.Jid
) )
where where
@ -62,6 +63,7 @@ import qualified Data.Text as Text
import Data.Typeable(Typeable) import Data.Typeable(Typeable)
import Data.XML.Types import Data.XML.Types
import qualified Network.TLS as TLS
import qualified Network as N import qualified Network as N
@ -619,28 +621,26 @@ instance Read StreamErrorCondition where
readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")]
readsPrec _ _ = [(StreamUndefinedCondition , "")] readsPrec _ _ = [(StreamUndefinedCondition , "")]
data XmppStreamError = XmppStreamError -- | Encapsulates information about an XMPP stream error.
data StreamErrorInfo = StreamErrorInfo
{ errorCondition :: !StreamErrorCondition { errorCondition :: !StreamErrorCondition
, errorText :: !(Maybe (Maybe LangTag, Text)) , errorText :: !(Maybe (Maybe LangTag, Text))
, errorXML :: !(Maybe Element) , errorXML :: !(Maybe Element)
} deriving (Show, Eq) } deriving (Show, Eq)
data StreamError = StreamError XmppStreamError -- | Signals an XMPP stream error or another unpredicted stream-related
| StreamUnknownError -- Something has gone wrong, but we don't -- situation.
-- know what data StreamFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
| StreamNotStreamElement Text -- element has been
| StreamInvalidStreamNamespace (Maybe Text) -- encountered.
| StreamInvalidStreamPrefix (Maybe Text) | StreamEndFailure -- ^ The server has closed the stream.
| StreamWrongTo (Maybe Text) | StreamOtherFailure -- ^ Undefined condition. More
| StreamWrongVersion (Maybe Text) -- information should be available in
| StreamWrongLangTag (Maybe Text) -- the log.
| StreamXMLError String -- If stream pickling goes wrong. deriving (Show, Eq, Typeable)
| StreamStreamEnd -- received closing stream tag
| StreamConnectionError instance Exception StreamFailure
deriving (Show, Eq, Typeable) instance Error StreamFailure where noMsg = StreamOtherFailure
instance Exception StreamError
instance Error StreamError where noMsg = StreamConnectionError
-- ============================================================================= -- =============================================================================
-- XML TYPES -- XML TYPES
@ -811,3 +811,16 @@ withConnection' action (Connection con) = do
mkConnection :: Connection_ -> IO Connection mkConnection :: Connection_ -> IO Connection
mkConnection con = Connection `fmap` (atomically $ newTMVar con) mkConnection con = Connection `fmap` (atomically $ newTMVar con)
-- | Failure conditions that may arise during TLS negotiation.
data TLSFailure = TLSError TLS.TLSError
| TLSNoServerSupport
| TLSNoConnection
| TLSConnectionSecured -- ^ Connection already secured
| TLSStreamError StreamFailure
| TLSFailureError -- General instance used for the Error instance (TODO)
deriving (Show, Eq, Typeable)
instance Error TLSFailure where
noMsg = TLSFailureError

Write Preview
Loading…
Cancel
Save