diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index d2547da..c276b8b 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -2,11 +2,11 @@ -- Module: $Header$ -- Description: RFC 6120 (XMPP: Core). -- License: Apache License 2.0 --- +-- -- Maintainer: info@jonkri.com -- Stability: unstable -- Portability: portable --- +-- -- The Extensible Messaging and Presence Protocol (XMPP) is an open technology -- for near-real-time communication, which powers a wide range of applications -- including instant messaging, presence, multi-party chat, voice and video @@ -15,14 +15,10 @@ -- asynchronous, end-to-end exchange of structured data by means of direct, -- persistent XML streams among a distributed network of globally addressable, -- presence-aware clients and servers. --- +-- -- Pontarius is an XMPP client library, implementing the core capabilities of -- XMPP (RFC 6120): setup and teardown of XML streams, channel encryption, -- 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 #-} @@ -149,6 +145,10 @@ module Network.Xmpp , LangTag(..) , exampleParams , PortID(..) + , StreamFailure(..) + , StreamErrorInfo(..) + , StreamErrorCondition(..) + , TLSFailure(..) ) where diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs index 50e9fe7..a61e556 100644 --- a/source/Network/Xmpp/Bind.hs +++ b/source/Network/Xmpp/Bind.hs @@ -34,8 +34,8 @@ xmppBind rsrc c = do jid <- case () of () | Right IQResult{iqResultPayload = Just b} <- answer , Right jid <- unpickleElem xpJid b -> return jid - | otherwise -> throw $ StreamXMLError - ("Bind couldn't unpickle JID from " ++ show answer) + | otherwise -> throw StreamOtherFailure + -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer) withConnection (modify $ \s -> s{sJid = Just jid}) c return jid where diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 070cab3..c6edf44 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -71,7 +71,7 @@ modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f writeTVar var (f x) -- | 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 modifyHandlers (\s -> s{connectionClosedHandler = \e -> eh e session}) session diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 1ab1a23..89bf372 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -23,7 +23,7 @@ import GHC.IO (unsafeUnmask) -- Worker to read stanzas from the stream and concurrently distribute them to -- all listener threads. readWorker :: (Stanza -> IO ()) - -> (StreamError -> IO ()) + -> (StreamFailure -> IO ()) -> TMVar Connection -> IO a readWorker onStanza onConnectionClosed stateRef = @@ -43,7 +43,7 @@ readWorker onStanza onConnectionClosed stateRef = [ Ex.Handler $ \(Interrupt t) -> do void $ handleInterrupts [t] return Nothing - , Ex.Handler $ \(e :: StreamError) -> do + , Ex.Handler $ \(e :: StreamFailure) -> do onConnectionClosed e return Nothing ] @@ -96,7 +96,7 @@ startThreadsWith stanzaHandler eh con = do _ <- forM threads killThread return () -- Call the connection closed handlers. - noCon :: TVar EventHandlers -> StreamError -> IO () + noCon :: TVar EventHandlers -> StreamFailure -> IO () noCon h e = do hands <- atomically $ readTVar h _ <- forkIO $ connectionClosedHandler hands e diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 962dbd1..0df18c3 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -15,7 +15,7 @@ import Network.Xmpp.Types -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- closed. data EventHandlers = EventHandlers - { connectionClosedHandler :: StreamError -> IO () + { connectionClosedHandler :: StreamFailure -> IO () } -- | Xmpp Context object diff --git a/source/Network/Xmpp/Connection.hs b/source/Network/Xmpp/Connection.hs index 2269d8b..4e0d31f 100644 --- a/source/Network/Xmpp/Connection.hs +++ b/source/Network/Xmpp/Connection.hs @@ -78,14 +78,14 @@ pullElement = do Ex.catches (do e <- runEventsSink (elements =$ await) case e of - Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Nothing -> liftIO $ Ex.throwIO StreamOtherFailure Just r -> return r ) - [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamStreamEnd) - , Ex.Handler (\(InvalidXmppXml s) - -> liftIO . Ex.throwIO $ StreamXMLError s) - , Ex.Handler $ \(e :: InvalidEventStream) - -> liftIO . Ex.throwIO $ StreamXMLError (show e) + [ Ex.Handler (\StreamEnd -> Ex.throwIO StreamEndFailure) + , Ex.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag + -> liftIO . Ex.throwIO $ StreamOtherFailure) -- TODO: Log: s + , Ex.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception + -> liftIO . Ex.throwIO $ StreamOtherFailure -- TODO: Log: (show e) ] -- Pulls an element and unpickles it. @@ -93,7 +93,7 @@ pullUnpickle :: PU [Node] a -> StateT Connection_ IO a pullUnpickle p = do res <- unpickleElem p <$> pullElement case res of - Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e) + Left e -> liftIO $ Ex.throwIO e Right r -> return r -- | 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 res <- pullUnpickle xpStreamStanza case res of - Left e -> liftIO . Ex.throwIO $ StreamError e + Left e -> liftIO . Ex.throwIO $ StreamErrorFailure e Right r -> return r -- Performs the given IO operation, catches any errors and re-throws everything @@ -121,7 +121,7 @@ xmppNoConnection :: Connection_ xmppNoConnection = Connection_ { cHand = Hand { cSend = \_ -> return False , cRecv = \_ -> Ex.throwIO - $ StreamConnectionError + $ StreamOtherFailure , cFlush = return () , cClose = return () } @@ -139,7 +139,7 @@ xmppNoConnection = Connection_ } where 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 -- updates the XmppConMonad Connection_ state. @@ -205,12 +205,12 @@ pushIQ' iqID to tp lang body con = do IQResultS r -> do unless (iqID == iqResultID r) . liftIO . Ex.throwIO $ - StreamXMLError - ("In sendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ - show (iqResultID r) ++ " .") + StreamOtherFailure + -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ + -- " /= " ++ show (iqResultID r) ++ " .") return $ Right r - _ -> liftIO . Ex.throwIO . StreamXMLError $ - "sendIQ': unexpected stanza type " + _ -> liftIO $ Ex.throwIO StreamOtherFailure + -- TODO: Log: "sendIQ': unexpected stanza type " -- | Send "" and wait for the server to finish processing and to -- close the connection. Any remaining elements from the server and whether or @@ -232,7 +232,7 @@ closeStreams = withConnection $ do collectElems es = do result <- Ex.try pullElement case result of - Left StreamStreamEnd -> return (es, True) + Left StreamEndFailure -> return (es, True) Left _ -> return (es, False) Right e -> collectElems (e:es) diff --git a/source/Network/Xmpp/Errors.hs b/source/Network/Xmpp/Errors.hs index 0172b6d..6e04d49 100644 --- a/source/Network/Xmpp/Errors.hs +++ b/source/Network/Xmpp/Errors.hs @@ -12,38 +12,3 @@ import Network.Xmpp.Types 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 _ = "" \ No newline at end of file diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 4de88c4..bf5e5fa 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -14,7 +14,7 @@ import Data.XML.Types import Network.Xmpp.Pickle import Network.Xmpp.Types -xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) +xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza) xpStreamStanza = xpEither xpStreamError xpStanza xpStanza :: PU [Node] Stanza @@ -182,10 +182,10 @@ xpIQError = xpWrap (xp2Tuple xpStanzaError (xpOption xpElemVerbatim)) ) -xpStreamError :: PU [Node] XmppStreamError +xpStreamError :: PU [Node] StreamErrorInfo xpStreamError = xpWrap - (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) - (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) + (\((cond,() ,()), txt, el) -> StreamErrorInfo cond txt el) + (\(StreamErrorInfo cond txt el) ->((cond,() ,()), txt, el)) (xpElemNodes (Name "error" diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index a11f9ef..8c104d3 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -13,7 +13,7 @@ data AuthError = AuthXmlError | AuthChallengeError | AuthServerAuthError -- ^ The server failed to authenticate -- itself - | AuthStreamError StreamError -- ^ Stream error on stream restart + | AuthStreamError StreamFailure -- ^ Stream error on stream restart -- TODO: Rename AuthConnectionError? | AuthConnectionError -- ^ Connection is closed | AuthError -- General instance used for the Error instance diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index 9070d0b..59b4b72 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -61,7 +61,7 @@ simpleConnect host port hostname username password resource = do -- | 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 con <- connectTcpRaw address port hostname result <- withConnection startStream con @@ -73,20 +73,20 @@ connectTcp address port hostname = do return $ Left e Right () -> return $ Right con where - toError (StreamNotStreamElement _name) = - XmppStreamError StreamInvalidXml Nothing Nothing - toError (StreamInvalidStreamNamespace _ns) = - XmppStreamError StreamInvalidNamespace Nothing Nothing - toError (StreamInvalidStreamPrefix _prefix) = - XmppStreamError StreamBadNamespacePrefix Nothing Nothing - toError (StreamWrongVersion _ver) = - XmppStreamError StreamUnsupportedVersion Nothing Nothing - toError (StreamWrongLangTag _) = - XmppStreamError StreamInvalidXml Nothing Nothing - toError StreamUnknownError = - XmppStreamError StreamBadFormat Nothing Nothing + -- toError (StreamNotStreamElement _name) = + -- XmppStreamFailure StreamInvalidXml Nothing Nothing + -- toError (StreamInvalidStreamNamespace _ns) = + -- XmppStreamFailure StreamInvalidNamespace Nothing Nothing + -- toError (StreamInvalidStreamPrefix _prefix) = + -- XmppStreamFailure StreamBadNamespacePrefix Nothing Nothing + -- toError (StreamWrongVersion _ver) = + -- XmppStreamFailure StreamUnsupportedVersion Nothing Nothing + -- toError (StreamWrongLangTag _) = + -- XmppStreamFailure StreamInvalidXml Nothing Nothing + -- toError StreamUnknownError = + -- XmppStreamFailure StreamBadFormat Nothing Nothing -- TODO: Catch remaining xmppStartStream errors. - toError _ = XmppStreamError StreamBadFormat Nothing Nothing + toError _ = StreamErrorInfo StreamBadFormat Nothing Nothing sessionXML :: Element sessionXML = pickleElem diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 9af9a5c..87bba00 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -36,12 +36,12 @@ streamUnpickleElem :: PU [Node] a -> StreamSink a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamXMLError (show l) + Left l -> throwError $ StreamOtherFailure -- TODO: Log: StreamXMLError (show l) Right r -> return r -- This is the conduit sink that handles the stream XML events. We extend it -- 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. throwOutJunk :: Monad m => Sink Event m () @@ -59,10 +59,10 @@ openElementFromEvents = do hd <- lift CL.head case hd of Just (EventBeginElement name attrs) -> return $ Element name attrs [] - _ -> throwError $ StreamConnectionError + _ -> throwError $ StreamOtherFailure -- 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 state <- get -- Set the `to' attribute depending on the state of the connection. @@ -71,7 +71,7 @@ startStream = runErrorT $ do then sJid state else Nothing ConnectionSecured -> sJid state case sHostname state of - Nothing -> throwError StreamConnectionError + Nothing -> throwError StreamOtherFailure Just hostname -> lift $ do pushXmlDecl pushOpenElement $ @@ -92,7 +92,7 @@ startStream = runErrorT $ do -- Sets a new Event source using the raw source (of bytes) -- and calls xmppStartStream. -restartStream :: StateT Connection_ IO (Either StreamError ()) +restartStream :: StateT Connection_ IO (Either StreamFailure ()) restartStream = do raw <- gets (cRecv . cHand) let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def) @@ -126,19 +126,19 @@ streamS expectedTo = do -- and validate what we get. el <- openElementFromEvents case unpickleElem xpStream el of - Left _ -> throwError $ findStreamErrors el + Left _ -> throwError StreamOtherFailure -- TODO: findStreamErrors el Right r -> validateData r - validateData (_, _, _, _, Nothing) = throwError $ StreamWrongLangTag Nothing + validateData (_, _, _, _, Nothing) = throwError StreamOtherFailure -- StreamWrongLangTag Nothing validateData (ver, from, to, i, Just lang) - | ver /= "1.0" = throwError $ StreamWrongVersion (Just ver) - | isJust to && to /= expectedTo = throwError $ StreamWrongTo (Text.pack . show <$> to) + | 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 = do e <- lift $ elements =$ CL.head case e of - Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Nothing -> liftIO $ Ex.throwIO StreamOtherFailure Just r -> streamUnpickleElem xpStreamFeatures r diff --git a/source/Network/Xmpp/TLS.hs b/source/Network/Xmpp/TLS.hs index 13742c7..ac68f3e 100644 --- a/source/Network/Xmpp/TLS.hs +++ b/source/Network/Xmpp/TLS.hs @@ -72,21 +72,9 @@ exampleParams = TLS.defaultParamsClient 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 ", waits for "", performs the TLS handshake, and --- restarts the stream. May throw errors. -startTLS :: TLS.TLSParams -> Connection -> IO (Either XmppTLSError ()) +-- restarts the stream. +startTLS :: TLS.TLSParams -> Connection -> IO (Either TLSFailure ()) startTLS params con = Ex.handle (return . Left . TLSError) . flip withConnection con . runErrorT $ do @@ -103,10 +91,10 @@ startTLS params con = Ex.handle (return . Left . TLSError) case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ -> - lift . Ex.throwIO $ StreamConnectionError + lift $ Ex.throwIO StreamOtherFailure -- TODO: find something more suitable - e -> lift . Ex.throwIO . StreamXMLError $ - "Unexpected element: " ++ ppElement e + e -> lift $ Ex.throwIO StreamOtherFailure + -- TODO: Log: "Unexpected element: " ++ ppElement e (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con) let newHand = Hand { cSend = catchPush . psh , cRecv = read diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 63e139a..6af878c 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -28,7 +28,7 @@ module Network.Xmpp.Types , StanzaErrorCondition(..) , StanzaErrorType(..) , StanzaId(..) - , StreamError(..) + , StreamFailure(..) , StreamErrorCondition(..) , Version(..) , HandleLike(..) @@ -38,8 +38,9 @@ module Network.Xmpp.Types , withConnection' , mkConnection , ConnectionState(..) - , XmppStreamError(..) + , StreamErrorInfo(..) , langTag + , TLSFailure(..) , module Network.Xmpp.Jid ) where @@ -62,6 +63,7 @@ import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types +import qualified Network.TLS as TLS import qualified Network as N @@ -619,28 +621,26 @@ instance Read StreamErrorCondition where readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] readsPrec _ _ = [(StreamUndefinedCondition , "")] -data XmppStreamError = XmppStreamError +-- | Encapsulates information about an XMPP stream error. +data StreamErrorInfo = StreamErrorInfo { errorCondition :: !StreamErrorCondition , errorText :: !(Maybe (Maybe LangTag, Text)) , errorXML :: !(Maybe Element) } deriving (Show, Eq) -data StreamError = StreamError XmppStreamError - | StreamUnknownError -- Something has gone wrong, but we don't - -- know what - | StreamNotStreamElement Text - | StreamInvalidStreamNamespace (Maybe Text) - | StreamInvalidStreamPrefix (Maybe Text) - | StreamWrongTo (Maybe Text) - | StreamWrongVersion (Maybe Text) - | StreamWrongLangTag (Maybe Text) - | StreamXMLError String -- If stream pickling goes wrong. - | StreamStreamEnd -- received closing stream tag - | StreamConnectionError - deriving (Show, Eq, Typeable) - -instance Exception StreamError -instance Error StreamError where noMsg = StreamConnectionError +-- | Signals an XMPP stream error or another unpredicted stream-related +-- situation. +data StreamFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream + -- element has been + -- encountered. + | StreamEndFailure -- ^ The server has closed the stream. + | StreamOtherFailure -- ^ Undefined condition. More + -- information should be available in + -- the log. + deriving (Show, Eq, Typeable) + +instance Exception StreamFailure +instance Error StreamFailure where noMsg = StreamOtherFailure -- ============================================================================= -- XML TYPES @@ -811,3 +811,16 @@ withConnection' action (Connection con) = do mkConnection :: Connection_ -> IO Connection 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