From f3d1a37146f7ed82ffde9453e6081ca3f51c58ce Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 28 Apr 2012 12:34:40 +0200 Subject: [PATCH] protected withConnection from asynchronous exceptions (may beed more work) renamed picklers to adhere to the xpPicklername schema added xmpp stream error data type and pickler changed fatal errors throw exceptions rather than ErrorT errors renamed pulls to pullSink renamed pullE pullElement renamed pull to pullStanza renamed sendS to sendStanza --- pontarius.cabal | 19 +++-- src/Network/XMPP.hs | 2 + src/Network/XMPP/Concurrent/IQ.hs | 2 +- src/Network/XMPP/Concurrent/Monad.hs | 45 ++++++++---- src/Network/XMPP/Concurrent/Threads.hs | 18 +++-- src/Network/XMPP/Marshal.hs | 31 +++++++- src/Network/XMPP/Monad.hs | 66 +++++++++-------- src/Network/XMPP/Pickle.hs | 17 ++++- src/Network/XMPP/SASL.hs | 6 +- src/Network/XMPP/Session.hs | 2 +- src/Network/XMPP/Stream.hs | 4 +- src/Network/XMPP/TLS.hs | 14 ++-- src/Network/XMPP/Types.hs | 99 ++++++++++++++++++++++++-- 13 files changed, 246 insertions(+), 79 deletions(-) diff --git a/pontarius.cabal b/pontarius.cabal index e555639..8dc8918 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -51,20 +51,25 @@ Library , data-default -any , stringprep >= 0.1.5 Exposed-modules: Network.XMPP - , Network.XMPP.Types - , Network.XMPP.SASL - , Network.XMPP.Stream - , Network.XMPP.Pickle + , Network.XMPP.Bind + , Network.XMPP.Concurrent , Network.XMPP.Marshal , Network.XMPP.Monad - , Network.XMPP.Concurrent - , Network.XMPP.TLS - , Network.XMPP.Bind + , Network.XMPP.Message + , Network.XMPP.Pickle + , Network.XMPP.Presence + , Network.XMPP.SASL , Network.XMPP.Session + , Network.XMPP.Stream + , Network.XMPP.TLS + , Network.XMPP.Types Other-modules: Network.XMPP.JID + , Network.XMPP.Concurrent.Types , Network.XMPP.Concurrent.IQ , Network.XMPP.Concurrent.Threads , Network.XMPP.Concurrent.Monad + , Text.XML.Stream.Elements + , Data.Conduit.TLS GHC-Options: -Wall diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index af4ed0a..1c87cb9 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -35,6 +35,8 @@ module Network.XMPP ( -- * Session management withNewSession + , withSession + , newSession , connect , startTLS , auth diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs index 6693397..500719c 100644 --- a/src/Network/XMPP/Concurrent/IQ.hs +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -27,7 +27,7 @@ sendIQ to tp lang body = do -- TODO: add timeout writeTVar handlers (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendS . IQRequestS $ IQRequest newId Nothing to lang tp body + sendStanza . IQRequestS $ IQRequest newId Nothing to lang tp body return ref -- | like 'sendIQ', but waits for the answer IQ diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 84cb77e..515d55b 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -4,6 +4,7 @@ import Network.XMPP.Types import Control.Concurrent import Control.Concurrent.STM +import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict @@ -34,7 +35,7 @@ listenIQChan tp ns = do writeTVar handlers (byNS', byID) return $ case present of Nothing -> Just iqCh - Just iqCh' -> Nothing + Just _iqCh' -> Nothing -- | get the inbound stanza channel, duplicates from master if necessary -- please note that once duplicated it will keep filling up, call @@ -92,8 +93,8 @@ pullPresence = do liftIO $ atomically $ readTChan c -- | Send a stanza to the server -sendS :: Stanza -> XMPP () -sendS a = do +sendStanza :: Stanza -> XMPP () +sendStanza a = do out <- asks outCh liftIO . atomically $ writeTChan out a return () @@ -159,24 +160,38 @@ withConnection a = do stateRef <- asks conStateRef write <- asks writeRef wait <- liftIO $ newEmptyTMVarIO - liftIO . throwTo readerId $ Interrupt wait - s <- liftIO . atomically $ do - putTMVar wait () - _ <- takeTMVar write - takeTMVar stateRef - (res, s') <- liftIO $ runStateT a s - liftIO . atomically $ do - putTMVar write (sConPushBS s') - putTMVar stateRef s' - return res + liftIO . Ex.mask_ $ do + throwTo readerId $ Interrupt wait + s <- Ex.catch ( atomically $ do + _ <- takeTMVar write + s <- takeTMVar stateRef + putTMVar wait () + return s + ) + (\e -> atomically (putTMVar wait ()) + >> Ex.throwIO (e :: Ex.SomeException) + -- No MVar taken + ) + Ex.catch ( do + (res, s') <- runStateT a s + atomically $ do + _ <- tryPutTMVar write (sConPushBS s') + _ <- tryPutTMVar stateRef s' + return () + return res + ) + -- we treat all Exceptions as fatal + (\e -> runStateT xmppKillConnection s + >> Ex.throwIO (e :: Ex.SomeException) + ) -- | Send a presence Stanza sendPresence :: Presence -> XMPP () -sendPresence = sendS . PresenceS +sendPresence = sendStanza . PresenceS -- | Send a Message Stanza sendMessage :: Message -> XMPP () -sendMessage = sendS . MessageS +sendMessage = sendStanza . MessageS modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 6a57dbb..7230205 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -32,6 +32,7 @@ import GHC.IO (unsafeUnmask) -- While waiting for the first semaphore(s) to flip we might receive -- another interrupt. When that happens we add it's semaphore to the -- list and retry waiting +handleInterrupts :: [TMVar ()] -> IO [()] handleInterrupts ts = Ex.catch (atomically $ forM ts takeTMVar) ( \(Interrupt t) -> handleInterrupts (t:ts)) @@ -51,11 +52,11 @@ readWorker messageC presenceC handlers stateRef = -- we don't know whether pull will -- necessarily be interruptible allowInterrupt - Just <$> runStateT pull s + Just <$> runStateT pullStanza s ) ) (\(Interrupt t) -> do - handleInterrupts [t] + void $ handleInterrupts [t] return Nothing ) liftIO . atomically $ do @@ -121,7 +122,7 @@ writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> takeTMVar writeR <*> readTChan stCh - _ <- write $ renderElement (pickleElem stanzaP next) + _ <- write $ renderElement (pickleElem xpStanza next) atomically $ putTMVar writeR write -- Two streams: input and output. Threads read from input stream and write to output stream. @@ -141,13 +142,13 @@ startThreads ) startThreads = do - writeLock <- newEmptyTMVarIO + writeLock <- newTMVarIO (\_ -> return ()) messageC <- newTChanIO presenceC <- newTChanIO outC <- newTChanIO handlers <- newTVarIO ( Map.empty, Map.empty) eh <- newTVarIO zeroEventHandlers - conS <- newEmptyTMVarIO + conS <- newTMVarIO xmppZeroConState lw <- forkIO $ writeWorker outC writeLock cp <- forkIO $ connPersist writeLock rd <- forkIO $ readWorker messageC presenceC handlers conS @@ -173,8 +174,11 @@ newSession = do return . read. show $ curId return (Session workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') -withNewSession :: XMPP b -> IO b -withNewSession a = newSession >>= runReaderT a +withNewSession :: XMPP b -> IO (Session, b) +withNewSession a = do + sess <- newSession + ret <- runReaderT a sess + return (sess, ret) withSession :: Session -> XMPP a -> IO a withSession = flip runReaderT diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 3d694e2..165a963 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -8,6 +8,9 @@ import Data.XML.Types import Network.XMPP.Pickle import Network.XMPP.Types +xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) +xpStreamEntity = xpEither xpStreamError xpStanza + stanzaSel :: Stanza -> Int stanzaSel (IQRequestS _) = 0 stanzaSel (IQResultS _) = 1 @@ -17,8 +20,8 @@ stanzaSel (MessageErrorS _) = 4 stanzaSel (PresenceS _) = 5 stanzaSel (PresenceErrorS _) = 6 -stanzaP :: PU [Node] Stanza -stanzaP = xpAlt stanzaSel +xpStanza :: PU [Node] Stanza +xpStanza = xpAlt stanzaSel [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError @@ -188,3 +191,27 @@ xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) (xpOption xpElemVerbatim) ) +xpStreamError :: PU [Node] XmppStreamError +xpStreamError = xpWrap + (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) + (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) + (xpElemNodes + (Name "error" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) $ xp3Tuple + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-streams" xpPrim + xpUnit + xpUnit + ) + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-streams}text" + xpLangTag + (xpContent xpId)) + ( xpOption xpElemVerbatim + -- application specific error conditions + ) + ) + + diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 013f186..e5a8b23 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -2,30 +2,31 @@ module Network.XMPP.Monad where -import Control.Applicative((<$>)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Applicative((<$>)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource -import Control.Concurrent -import Control.Monad.State.Strict +import Control.Concurrent +import qualified Control.Exception as Ex +import Control.Monad.State.Strict -import Data.ByteString as BS -import Data.Conduit -import Data.Conduit.Binary as CB -import Data.Text(Text) -import Data.XML.Pickle -import Data.XML.Types +import Data.ByteString as BS +import Data.Conduit +import Data.Conduit.Binary as CB +import Data.Text(Text) +import Data.XML.Pickle +import Data.XML.Types -import Network -import Network.XMPP.Types -import Network.XMPP.Marshal -import Network.XMPP.Pickle +import Network +import Network.XMPP.Types +import Network.XMPP.Marshal +import Network.XMPP.Pickle -import System.IO +import System.IO -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse as XP +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP pushN :: Element -> XMPPConMonad () pushN x = do @@ -33,7 +34,7 @@ pushN x = do liftIO . sink $ renderElement x push :: Stanza -> XMPPConMonad () -push = pushN . pickleElem stanzaP +push = pushN . pickleElem xpStanza pushOpen :: Element -> XMPPConMonad () pushOpen e = do @@ -41,21 +42,29 @@ pushOpen e = do liftIO . sink $ renderOpenElement e return () -pulls :: Sink Event IO b -> XMPPConMonad b -pulls snk = do +pullSink :: Sink Event IO b -> XMPPConMonad b +pullSink snk = do source <- gets sConSrc (src', r) <- lift $ source $$+ snk modify $ (\s -> s {sConSrc = src'}) return r -pullE :: XMPPConMonad Element -pullE = pulls elementFromEvents +pullElement :: XMPPConMonad Element +pullElement = pullSink elementFromEvents pullPickle :: PU [Node] a -> XMPPConMonad a -pullPickle p = unpickleElem' p <$> pullE - -pull :: XMPPConMonad Stanza -pull = pullPickle stanzaP +pullPickle p = do + res <- unpickleElem p <$> pullElement + case res of + Left e -> liftIO . Ex.throwIO $ StreamXMLError e + Right r -> return r + +pullStanza :: XMPPConMonad Stanza +pullStanza = do + res <- pullPickle xpStreamEntity + case res of + Left e -> liftIO . Ex.throwIO $ StreamError e + Right r -> return r xmppFromHandle :: Handle -> Text @@ -119,7 +128,6 @@ xmppRawConnect host hostname = do (hClose con) put st - xmppNewSession :: XMPPConMonad a -> IO (a, XMPPConState) xmppNewSession action = do runStateT action xmppZeroConState diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 347e8a5..bc611d8 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -5,7 +5,21 @@ -- Marshalling between XML and Native Types -module Network.XMPP.Pickle where +module Network.XMPP.Pickle + ( mbToBool + , xpElemEmpty + , xmlLang + , xpLangTag + , xpNodeElem + , ignoreAttrs + , mbl + , lmb + , right + , unpickleElem' + , unpickleElem + , pickleElem + , ppElement + ) where import Data.XML.Types import Data.XML.Pickle @@ -65,3 +79,4 @@ unpickleElem p x = unpickle (xpNodeElem p) x pickleElem :: PU [Node] a -> a -> Element pickleElem p = pickle $ xpNodeElem p + diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 24f4288..87e3325 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -5,7 +5,6 @@ import Control.Applicative import Control.Arrow (left) import Control.Monad import Control.Monad.Error -import Control.Monad.IO.Class import Control.Monad.State.Strict import qualified Crypto.Classes as CC @@ -80,7 +79,8 @@ xmppStartSASL realm username passwd = runErrorT $ do unless ("DIGEST-MD5" `elem` mechanisms) . throwError $ SaslMechanismError mechanisms lift . pushN $ saslInitE "DIGEST-MD5" - challenge' <- lift $ B64.decode . Text.encodeUtf8<$> pullPickle challengePickle + challenge' <- lift $ B64.decode . Text.encodeUtf8 + <$> pullPickle challengePickle challenge <- case challenge' of Left _e -> throwError SaslChallengeError Right r -> return r @@ -94,7 +94,7 @@ xmppStartSASL realm username passwd = runErrorT $ do Left _x -> throwError $ SaslXmlError Right _ -> return () lift $ pushN saslResponse2E - e <- lift pullE + e <- lift pullElement case e of Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () _ -> throwError SaslXmlError -- TODO: investigate diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 8e3082f..b21c265 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -28,7 +28,7 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" xmppSession :: XMPPConMonad () xmppSession = do push $ sessionIQ - answer <- pull + answer <- pullStanza let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer return () diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index c192116..be79acf 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -27,7 +27,7 @@ streamUnpickleElem :: PU [Node] a -> ErrorT StreamError (Pipe Event Void IO) a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamUnpickleError l + Left l -> throwError $ StreamXMLError l Right r -> return r type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a @@ -55,7 +55,7 @@ xmppStartStream = runErrorT $ do Nothing -> throwError StreamConnectionError Just hostname -> lift . pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pulls $ runErrorT xmppStream + features <- ErrorT . pullSink $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 8cfc0a4..5d2418d 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -3,8 +3,6 @@ module Network.XMPP.TLS where -import Control.Applicative((<$>)) -import Control.Arrow(left) import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error @@ -15,6 +13,7 @@ import Data.Typeable import Data.XML.Types import Network.XMPP.Monad +import Network.XMPP.Pickle(ppElement) import Network.XMPP.Stream import Network.XMPP.Types @@ -45,7 +44,6 @@ data XMPPTLSError = TLSError TLSError instance Error XMPPTLSError where noMsg = TLSNoConnection -- TODO: What should we choose here? -instance Ex.Exception XMPPTLSError xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) @@ -56,10 +54,14 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) handle <- maybe (throwError TLSNoConnection) return handle' when (stls features == Nothing) $ throwError TLSNoServerSupport lift $ pushN starttlsE - answer <- lift $ pullE + answer <- lift $ pullElement case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () - _ -> throwError $ TLSStreamError StreamXMLError + Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ + -> lift . Ex.throwIO $ StreamConnectionError + -- TODO: find something more suitable + e -> lift . Ex.throwIO . StreamXMLError + $ "Unexpected element: " ++ ppElement e (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw @@ -68,7 +70,7 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) , sConPushBS = psh , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) - ErrorT $ (left TLSStreamError) <$> xmppRestartStream + either (lift . Ex.throwIO) return =<< lift xmppRestartStream modify (\s -> s{sHaveTLS = True}) return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index c8f4619..9013eb2 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -40,6 +40,7 @@ module Network.XMPP.Types , XMPPConMonad , XMPPConState(..) , XMPPT(..) + , XmppStreamError(..) , parseLangTag , module Network.XMPP.JID ) @@ -338,7 +339,6 @@ instance Read ShowType where -- wrapped in the @StanzaError@ type. -- TODO: Sender XML is (optional and is) not included. - data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType , stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorText :: Maybe (Maybe LangTag, Text) @@ -537,14 +537,103 @@ instance Read SASLError where data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) -data StreamError = StreamError String +-- TODO: document the error cases +data StreamErrorCondition = StreamBadFormat + | StreamBadNamespacePrefix + | StreamConflict + | StreamConnectionTimeout + | StreamHostGone + | StreamHostUnknown + | StreamImproperAddressing + | StreamInternalServerError + | StreamInvalidFrom + | StreamInvalidNamespace + | StreamInvalidXml + | StreamNotAuthorized + | StreamNotWellFormed + | StreamPolicyViolation + | StreamRemoteConnectionFailed + | StreamReset + | StreamResourceConstraint + | StreamRestrictedXml + | StreamSeeOtherHost + | StreamSystemShutdown + | StreamUndefinedCondition + | StreamUnsupportedEncoding + | StreamUnsupportedFeature + | StreamUnsupportedStanzaType + | StreamUnsupportedVersion + deriving Eq + +instance Show StreamErrorCondition where + show StreamBadFormat = "bad-format" + show StreamBadNamespacePrefix = "bad-namespace-prefix" + show StreamConflict = "conflict" + show StreamConnectionTimeout = "connection-timeout" + show StreamHostGone = "host-gone" + show StreamHostUnknown = "host-unknown" + show StreamImproperAddressing = "improper-addressing" + show StreamInternalServerError = "internal-server-error" + show StreamInvalidFrom = "invalid-from" + show StreamInvalidNamespace = "invalid-namespace" + show StreamInvalidXml = "invalid-xml" + show StreamNotAuthorized = "not-authorized" + show StreamNotWellFormed = "not-well-formed" + show StreamPolicyViolation = "policy-violation" + show StreamRemoteConnectionFailed = "remote-connection-failed" + show StreamReset = "reset" + show StreamResourceConstraint = "resource-constraint" + show StreamRestrictedXml = "restricted-xml" + show StreamSeeOtherHost = "see-other-host" + show StreamSystemShutdown = "system-shutdown" + show StreamUndefinedCondition = "undefined-condition" + show StreamUnsupportedEncoding = "unsupported-encoding" + show StreamUnsupportedFeature = "unsupported-feature" + show StreamUnsupportedStanzaType = "unsupported-stanza-type" + show StreamUnsupportedVersion = "unsupported-version" + +instance Read StreamErrorCondition where + readsPrec _ "bad-format" = [(StreamBadFormat , "")] + readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] + readsPrec _ "conflict" = [(StreamConflict , "")] + readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] + readsPrec _ "host-gone" = [(StreamHostGone , "")] + readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] + readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] + readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] + readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] + readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] + readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] + readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] + readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] + readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] + readsPrec _ "remote-connection-failed" = [(StreamRemoteConnectionFailed , "")] + readsPrec _ "reset" = [(StreamReset , "")] + readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] + readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] + readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] + readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] + readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] + readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] + readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] + readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType , "")] + readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] + readsPrec _ _ = [(StreamUndefinedCondition , "")] + +data XmppStreamError = XmppStreamError + { errorCondition :: StreamErrorCondition + , errorText :: Maybe (Maybe LangTag, Text) + , errorXML :: Maybe Element + } deriving (Show, Eq) + + +data StreamError = StreamError XmppStreamError | StreamWrongVersion Text - | StreamXMLError - | StreamUnpickleError String + | StreamXMLError String | StreamConnectionError deriving (Show, Eq, Typeable) instance Exception StreamError -instance Error StreamError where strMsg = StreamError +instance Error StreamError where noMsg = StreamConnectionError -- ============================================================================= -- XML TYPES