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

@@ -51,20 +51,25 @@ Library
                , data-default      -any
                , stringprep        >= 0.1.5
   Exposed-modules: Network.XMPP
-                 , Network.XMPP.Types
+                 , Network.XMPP.Bind
-                 , Network.XMPP.SASL
+                 , Network.XMPP.Concurrent
-                 , Network.XMPP.Stream
-                 , Network.XMPP.Pickle
                  , Network.XMPP.Marshal
                  , Network.XMPP.Monad
-                 , Network.XMPP.Concurrent
+                 , Network.XMPP.Message
-                 , Network.XMPP.TLS
+                 , Network.XMPP.Pickle
-                 , Network.XMPP.Bind
+                 , 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
 
 

src/Network/XMPP.hs

@@ -35,6 +35,8 @@
 module Network.XMPP
   ( -- * Session management
     withNewSession
+  , withSession
+  , newSession
   , connect
   , startTLS
   , auth

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

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 ()
+sendStanza :: Stanza -> XMPP ()
-sendS a = do
+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
+  liftIO . Ex.mask_ $ do
-  s <- liftIO . atomically $ do
+      throwTo readerId $ Interrupt wait
-    putTMVar wait ()
+      s <- Ex.catch ( atomically $ do
-    _ <- takeTMVar write
+                         _ <- takeTMVar write
-    takeTMVar stateRef
+                         s <- takeTMVar stateRef
-  (res, s') <- liftIO $ runStateT a s
+                         putTMVar wait ()
-  liftIO . atomically $ do
+                         return s
-    putTMVar write (sConPushBS s')
+                    )
-    putTMVar stateRef s'
+               (\e -> atomically (putTMVar wait ())
-  return res
+                      >>  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 ()

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 :: XMPP b -> IO (Session, b)
-withNewSession a = newSession >>= runReaderT a
+withNewSession a = do
+  sess <- newSession
+  ret <- runReaderT a sess
+  return (sess, ret)
 
 withSession :: Session -> XMPP a -> IO a
 withSession = flip runReaderT

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
+xpStanza :: PU [Node] Stanza
-stanzaP = xpAlt stanzaSel
+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
+                  )
+                )
+
+

src/Network/XMPP/Monad.hs

@@ -2,30 +2,31 @@
 
 module Network.XMPP.Monad where
 
-import Control.Applicative((<$>))
+import           Control.Applicative((<$>))
-import Control.Monad
+import           Control.Monad
-import Control.Monad.IO.Class
+import           Control.Monad.IO.Class
-import Control.Monad.Trans.Class
+import           Control.Monad.Trans.Class
 --import Control.Monad.Trans.Resource
-import Control.Concurrent
+import           Control.Concurrent
-import Control.Monad.State.Strict
+import qualified Control.Exception as Ex
+import           Control.Monad.State.Strict
 
-import Data.ByteString as BS
+import           Data.ByteString as BS
-import Data.Conduit
+import           Data.Conduit
-import Data.Conduit.Binary as CB
+import           Data.Conduit.Binary as CB
-import Data.Text(Text)
+import           Data.Text(Text)
-import Data.XML.Pickle
+import           Data.XML.Pickle
-import Data.XML.Types
+import           Data.XML.Types
 
-import Network
+import           Network
-import Network.XMPP.Types
+import           Network.XMPP.Types
-import Network.XMPP.Marshal
+import           Network.XMPP.Marshal
-import Network.XMPP.Pickle
+import           Network.XMPP.Pickle
 
-import System.IO
+import           System.IO
 
-import Text.XML.Stream.Elements
+import           Text.XML.Stream.Elements
-import Text.XML.Stream.Parse as XP
+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
+pullSink :: Sink Event IO b -> XMPPConMonad b
-pulls snk = do
+pullSink snk = do
   source <- gets sConSrc
   (src', r) <- lift $ source $$+ snk
   modify $ (\s -> s {sConSrc = src'})
   return r
 
-pullE :: XMPPConMonad Element
+pullElement :: XMPPConMonad Element
-pullE = pulls elementFromEvents
+pullElement = pullSink elementFromEvents
 
 pullPickle :: PU [Node] a -> XMPPConMonad a
-pullPickle p = unpickleElem' p <$> pullE
+pullPickle p = do
-
+    res <- unpickleElem p <$> pullElement
-pull :: XMPPConMonad Stanza
+    case res of
-pull = pullPickle stanzaP
+        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

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
 
+

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

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 ()
 

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 ()
 

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 ()
 

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
+                 | StreamXMLError String
-                 | StreamUnpickleError String
                  | StreamConnectionError
                  deriving (Show, Eq, Typeable)
 instance Exception StreamError
-instance Error StreamError where strMsg = StreamError
+instance Error StreamError where noMsg = StreamConnectionError
 
 -- =============================================================================
 --  XML TYPES