diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 97b8885..53d7ba9 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -1,36 +1,25 @@ --- Copyright © 2010-2012 Jon Kristensen. --- Copyright 2012 Philipp Balzarek --- See the LICENSE file in the --- Pontarius distribution for more details. - -- | -- Module: $Header$ --- Description: Pontarius API --- Copyright: Copyright © 2010-2012 Jon Kristensen +-- Description: A work in progress client implementation of RFC 6120 (XMPP: +-- Core). -- License: Apache License 2.0 -- -- Maintainer: jon.kristensen@nejla.com -- Stability: unstable -- Portability: portable -- --- The Extensible Messaging and Presence Protocol (XMPP) is an open technology for --- real-time communication, which powers a wide range of applications including --- instant messaging, presence, multi-party chat, voice and video calls, --- collaboration, lightweight middleware, content syndication, and generalized --- routing of XML data. --- Pontarius an XMPP client library, implementing the core capabilities of XMPP --- (RFC 6120). --- --- Developers using this library are assumed to understand how XMPP --- works. --- --- This module will be documented soon. +-- The Extensible Messaging and Presence Protocol (XMPP) is an open technology +-- for real-time communication, which powers a wide range of applications +-- including instant messaging, presence, multi-party chat, voice and video +-- calls, collaboration, lightweight middleware, content syndication, and +-- generalized routing of XML data. Pontarius an XMPP client library, +-- implementing the core capabilities of XMPP (RFC 6120). -- --- 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. +-- 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 #-} module Network.XMPP ( -- * Session management @@ -46,37 +35,37 @@ module Network.XMPP , setConnectionClosedHandler -- * JID -- | A JID (historically: Jabber ID) is XMPPs native format - -- for addressing entities in the network. It is somewhat similar to an - -- email-address but contains three parts instead of two: + -- for addressing entities in the network. It is somewhat similar to an e-mail + -- address but contains three parts instead of two: , JID(..) -- * Stanzas - -- | @Stanzas@ are the the smallest unit of communication in @XMPP@. They - -- come in 3 flavors: + -- | @Stanzas@ are the the smallest unit of communication in @XMPP@. They come + -- in 3 flavors: -- - -- * @'Message'@, for traditional IM-style message passing between peers + -- * @'Message'@, for traditional push-style message passing between peers -- -- * @'Presence'@, for communicating status updates -- - -- * IQ (info/query), with a request-response semantics + -- * IQ (info/query), for request-response semantics communication -- -- All stanza types have the following attributes in common: -- - -- * The /id/ attribute is used by the originating entity to track - -- any response or error stanza that it might receive in relation to - -- the generated stanza from another entity (such as an intermediate - -- server or the intended recipient). It is up to the originating - -- entity whether the value of the 'id' attribute is unique only - -- within its current stream or unique globally. + -- * The /id/ attribute is used by the originating entity to track any + -- response or error stanza that it might receive in relation to the + -- generated stanza from another entity (such as an intermediate server or + -- the intended recipient). It is up to the originating entity whether the + -- value of the 'id' attribute is unique only within its current stream or + -- unique globally. -- -- * The /from/ attribute specifies the JID of the sender. -- - -- * The /to/ attribute specifies the JID of the intended recipient - -- for the stanza. + -- * The /to/ attribute specifies the JID of the intended recipient for the + -- stanza. -- - -- * The /type/ attribute specifies the purpose or context of the - -- message, presence, or IQ stanza. The particular allowable values - -- for the 'type' attribute vary depending on whether the stanza is - -- a message, presence, or IQ stanza. + -- * The /type/ attribute specifies the purpose or context of the message, + -- presence, or IQ stanza. The particular allowable values for the 'type' + -- attribute vary depending on whether the stanza is a message, presence, + -- or IQ stanza. -- ** Messages -- | The /message/ stanza is a /push/ mechanism whereby one entity pushes @@ -97,10 +86,9 @@ module Network.XMPP , waitForMessageError , filterMessages -- ** Presence - -- | The /presence/ stanza is a specialized /broadcast/ - -- or /publish-subscribe/ mechanism, whereby multiple entities - -- receive information about an entity to which they have - -- subscribed. + -- | The /presence/ stanza is a specialized /broadcast/ or /publish-subscribe/ + -- mechanism, whereby multiple entities receive information about an entity to + -- which they have subscribed. -- -- , Presence(..) @@ -118,11 +106,10 @@ module Network.XMPP -- an entity to make a request of, and receive a response from, another -- entity. The data content and precise semantics of the request and response -- is defined by the schema or other structural definition associated with the - -- XML namespace that - -- qualifies the direct child element of the IQ element. IQ interactions - -- follow a common pattern of structured data - -- exchange such as get/result or set/result (although an error can be returned - -- in reply to a request if appropriate) + -- XML namespace that qualifies the direct child element of the IQ element. IQ + -- interactions follow a common pattern of structured data exchange such as + -- get/result or set/result (although an error can be returned in reply to a + -- request if appropriate) -- -- , IQRequest(..) diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index b10db9d..bc46f8a 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -14,8 +14,8 @@ import Data.XML.Types import Network.XMPP.Pickle import Network.XMPP.Types -xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) -xpStreamEntity = xpEither xpStreamError xpStanza +xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) +xpStreamStanza = xpEither xpStreamError xpStanza xpStanza :: PU [Node] Stanza xpStanza = xpAlt stanzaSel diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 9b9e65c..9d3297d 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -32,36 +32,38 @@ import Text.XML.Stream.Elements import Text.XML.Stream.Parse as XP import Text.XML.Unresolved(InvalidEventStream(..)) -pushN :: Element -> XMPPConMonad Bool -pushN x = do - sink <- gets sConPushBS - liftIO . sink $ renderElement x - -push :: Stanza -> XMPPConMonad Bool -push = pushN . pickleElem xpStanza - -pushOpen :: Element -> XMPPConMonad Bool -pushOpen e = do - sink <- gets sConPushBS - liftIO . sink $ renderOpenElement e - -pullSink :: Sink Event IO b -> XMPPConMonad b -pullSink snk = do - source <- gets sConSrc - (_, r) <- lift $ source $$+ snk - return r +pushElement :: Element -> XMPPConMonad Bool +pushElement x = do + sink <- gets sConPushBS + liftIO . sink $ renderElement x + +pushStanza :: Stanza -> XMPPConMonad Bool +pushStanza = pushElement . pickleElem xpStanza + +pushOpenElement :: Element -> XMPPConMonad Bool +pushOpenElement e = do + sink <- gets sConPushBS + liftIO . sink $ renderOpenElement e + +-- `Connect-and-resumes' the given sink to the connection source, and pulls a +-- `b' value. +pullToSink :: Sink Event IO b -> XMPPConMonad b +pullToSink snk = do + source <- gets sConSrc + (_, r) <- lift $ source $$+ snk + return r pullElement :: XMPPConMonad Element pullElement = do Ex.catch (do - e <- pullSink (elements =$ CL.head) + e <- pullToSink (elements =$ CL.head) case e of Nothing -> liftIO $ Ex.throwIO StreamConnectionError Just r -> return r ) (\(InvalidEventStream s) -> liftIO . Ex.throwIO $ StreamXMLError s) - +-- Pulls an element and unpickles it. pullPickle :: PU [Node] a -> XMPPConMonad a pullPickle p = do res <- unpickleElem p <$> pullElement @@ -69,27 +71,30 @@ pullPickle p = do Left e -> liftIO . Ex.throwIO $ StreamXMLError e Right r -> return r +-- Pulls a stanza from the stream. Throws an error on failure. pullStanza :: XMPPConMonad Stanza pullStanza = do - res <- pullPickle xpStreamEntity + res <- pullPickle xpStreamStanza case res of Left e -> liftIO . Ex.throwIO $ StreamError e Right r -> return r -catchPush p = Ex.catch (p >> return True) - (\e -> case GIE.ioe_type e of - GIE.ResourceVanished -> return False - _ -> Ex.throwIO e - ) - -zeroSource :: Source IO output -zeroSource = liftIO . Ex.throwIO $ StreamConnectionError - +-- Performs the given IO operation, catches any errors and re-throws everything +-- except the `ResourceVanished' error. +catchPush :: IO () -> IO Bool +catchPush p = Ex.catch + (p >> return True) + (\e -> case GIE.ioe_type e of + GIE.ResourceVanished -> return False + _ -> Ex.throwIO e + ) + +-- XmppConnection state used when there is no connection. xmppNoConnection :: XmppConnection xmppNoConnection = XmppConnection { sConSrc = zeroSource , sRawSrc = zeroSource - , sConPushBS = \_ -> return False + , sConPushBS = \_ -> return False -- Nothing has been sent. , sConHandle = Nothing , sFeatures = SF Nothing [] [] , sConnectionState = XmppConnectionClosed @@ -98,51 +103,62 @@ xmppNoConnection = XmppConnection , sResource = Nothing , sCloseConnection = return () } + where + zeroSource :: Source IO output + zeroSource = liftIO . Ex.throwIO $ StreamConnectionError +-- Connects to the given hostname on port 5222 (TODO: Make this dynamic) and +-- updates the XMPPConMonad XmppConnection state. xmppRawConnect :: HostName -> Text -> XMPPConMonad () xmppRawConnect host hostname = do - uname <- gets sUsername - con <- liftIO $ do - con <- connectTo host (PortNumber 5222) - hSetBuffering con NoBuffering - return con - let raw = sourceHandle con - src <- liftIO . bufferSource $ raw $= XP.parseBytes def - let st = XmppConnection - src - (raw) - (catchPush . BS.hPut con) - (Just con) - (SF Nothing [] []) - XmppConnectionPlain - (Just hostname) - uname - Nothing - (hClose con) - put st - + uname <- gets sUsername + con <- liftIO $ do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + return con + let raw = sourceHandle con + src <- liftIO . bufferSource $ raw $= XP.parseBytes def + let st = XmppConnection + src + raw + (catchPush . BS.hPut con) + (Just con) + (SF Nothing [] []) + XmppConnectionPlain + (Just hostname) + uname + Nothing + (hClose con) + put st + +-- Execute a XMPPConMonad computation. xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection) -xmppNewSession action = do - runStateT action xmppNoConnection +xmppNewSession action = runStateT action xmppNoConnection +-- Closes the connection and updates the XMPPConMonad XmppConnection state. xmppKillConnection :: XMPPConMonad () xmppKillConnection = do cc <- gets sCloseConnection void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) put xmppNoConnection -xmppSendIQ' :: StanzaId -> Maybe JID -> IQRequestType - -> Maybe LangTag -> Element +-- Sends an IQ request and waits for the response. If the response ID does not +-- match the outgoing ID, an error is thrown. +xmppSendIQ' :: StanzaId + -> Maybe JID + -> IQRequestType + -> Maybe LangTag + -> Element -> XMPPConMonad (Either IQError IQResult) xmppSendIQ' iqID to tp lang body = do - push . IQRequestS $ IQRequest iqID Nothing to lang tp body + pushStanza . IQRequestS $ IQRequest iqID Nothing to lang tp body res <- pullPickle $ xpEither xpIQError xpIQResult case res of Left e -> return $ Left e Right iq' -> do - unless (iqID == iqResultID iq') . liftIO . Ex.throwIO $ - StreamXMLError - ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ - " /= " ++ show (iqResultID iq') ++ " .") - return $ Right iq' - + unless + (iqID == iqResultID iq') . liftIO . Ex.throwIO $ + StreamXMLError + ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ " /= " ++ + show (iqResultID iq') ++ " .") + return $ Right iq' \ No newline at end of file diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 035fb12..e922903 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -73,6 +73,7 @@ unpickleElem' p x = case unpickle (xpNodeElem p) x of Left l -> error $ l ++ "\n saw: " ++ ppElement x Right r -> r +-- Given a pickler and an element, produces an object. unpickleElem :: PU [Node] a -> Element -> Either String a unpickleElem p x = unpickle (xpNodeElem p) x diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index a820f1d..7fb1b99 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -66,7 +66,7 @@ xmppSASL uname passwd = runErrorT $ do unless ("DIGEST-MD5" `elem` mechanisms) . throwError $ AuthMechanismError mechanisms -- Push element and receive the challenge (in XMPPConMonad). - _ <- lift . pushN $ saslInitE "DIGEST-MD5" -- TODO: Check boolean? + _ <- lift . pushElement $ saslInitE "DIGEST-MD5" -- TODO: Check boolean? challenge' <- lift $ B64.decode . Text.encodeUtf8 <$> pullPickle challengePickle challenge <- case challenge' of @@ -76,13 +76,13 @@ xmppSASL uname passwd = runErrorT $ do Left _ -> throwError AuthChallengeError Right p -> return p g <- liftIO Random.newStdGen - _ <- lift . pushN . -- TODO: Check boolean? + _ <- lift . pushElement . -- TODO: Check boolean? saslResponseE $ createResponse g realm pairs challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) case challenge2 of Left _x -> throwError AuthXmlError Right _ -> return () - lift $ pushN saslResponse2E + lift $ pushElement saslResponse2E e <- lift pullElement case e of Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index ef96fb0..94da48f 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -1,5 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Network.XMPP.Stream where @@ -24,98 +24,106 @@ import Text.XML.Stream.Parse as XP -- import Text.XML.Stream.Elements +-- Unpickles and returns a stream element. Throws a StreamXMLError on failure. streamUnpickleElem :: PU [Node] a -> Element -> ErrorT StreamError (Pipe Event Void IO) a streamUnpickleElem p x = do - case unpickleElem p x of - Left l -> throwError $ StreamXMLError l - Right r -> return r + case unpickleElem p x of + Left l -> throwError $ StreamXMLError l + Right r -> return r -type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a +-- This is the conduit sink that handles the stream XML events. We extend it +-- with ErrorT capabilities. +type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a +-- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () throwOutJunk = do - next <- CL.peek - case next of - Nothing -> return () - Just (EventBeginElement _ _) -> return () - _ -> CL.drop 1 >> throwOutJunk + next <- CL.peek + case next of + Nothing -> return () -- This will only happen if the stream is closed. + Just (EventBeginElement _ _) -> return () + _ -> CL.drop 1 >> throwOutJunk +-- Returns an (empty) Element from a stream of XML events. openElementFromEvents :: StreamSink Element openElementFromEvents = do - lift throwOutJunk - hd <- lift CL.head - case hd of - Just (EventBeginElement name attrs) -> return $ Element name attrs [] - _ -> throwError $ StreamConnectionError + lift throwOutJunk + hd <- lift CL.head + case hd of + Just (EventBeginElement name attrs) -> return $ Element name attrs [] + _ -> throwError $ StreamConnectionError +-- Sends the initial stream:stream element and pulls the server features. xmppStartStream :: XMPPConMonad (Either StreamError ()) xmppStartStream = runErrorT $ do - hostname' <- gets sHostname - case hostname' of - Nothing -> throwError StreamConnectionError - Just hostname -> lift . pushOpen $ - pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pullSink $ runErrorT xmppStream - modify (\s -> s {sFeatures = features}) - return () - + hostname' <- gets sHostname + case hostname' of + Nothing -> throwError StreamConnectionError + Just hostname -> lift . pushOpenElement $ + pickleElem pickleStream ("1.0", Nothing, Just hostname) + features <- ErrorT . pullToSink $ runErrorT xmppStream + modify (\s -> s {sFeatures = features}) + return () + +-- Creates a new connection source (of Events) using the raw source (of bytes) +-- and calls xmppStartStream. xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream = do - raw <- gets sRawSrc - newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def - modify (\s -> s{sConSrc = newsrc}) - xmppStartStream - + raw <- gets sRawSrc + newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def + modify (\s -> s{sConSrc = newsrc}) + xmppStartStream +-- Reads the (partial) stream:stream and the server features from the stream. xmppStream :: StreamSink ServerFeatures xmppStream = do - xmppStreamHeader - xmppStreamFeatures - -xmppStreamHeader :: StreamSink () -xmppStreamHeader = do - lift $ throwOutJunk - (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents - unless (ver == "1.0") . throwError $ StreamWrongVersion ver - return() - - -xmppStreamFeatures :: StreamSink ServerFeatures -xmppStreamFeatures = do - e <- lift $ elements =$ CL.head - case e of - Nothing -> liftIO $ Ex.throwIO StreamConnectionError - Just r -> streamUnpickleElem pickleStreamFeatures r - --- Pickling - + xmppStreamHeader + xmppStreamFeatures + where + xmppStreamHeader :: StreamSink () + xmppStreamHeader = do + lift $ throwOutJunk + (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents + unless (ver == "1.0") . throwError $ StreamWrongVersion ver + return () + xmppStreamFeatures :: StreamSink ServerFeatures + xmppStreamFeatures = do + e <- lift $ elements =$ CL.head + case e of + Nothing -> liftIO $ Ex.throwIO StreamConnectionError + Just r -> streamUnpickleElem pickleStreamFeatures r + +-- Pickler/Unpickler for the stream, with the version, from and to attributes. pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) -pickleStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - (xpTriple - (xpAttr "version" xpId) - (xpOption $ xpAttr "from" xpId) - (xpOption $ xpAttr "to" xpId) - ) - -pickleTLSFeature :: PU [Node] Bool -pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" - (xpElemExists "required") - -pickleSaslFeature :: PU [Node] [Text] -pickleSaslFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" - (xpAll $ xpElemNodes - "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId) ) - +pickleStream = xpElemAttrs + (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + (xpTriple + (xpAttr "version" xpId) + (xpOption $ xpAttr "from" xpId) + (xpOption $ xpAttr "to" xpId) + ) + +-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. pickleStreamFeatures :: PU [Node] ServerFeatures -pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest) - (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) - $ - xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream")) - (xpTriple - (xpOption pickleTLSFeature) - (xpOption pickleSaslFeature) - (xpAll xpElemVerbatim) - ) - +pickleStreamFeatures = xpWrap + (\(tls, sasl, rest) -> SF tls (mbl sasl) rest) + (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) + (xpElemNodes (Name + "features" (Just "http://etherx.jabber.org/streams") (Just "stream")) + (xpTriple + (xpOption pickleTLSFeature) + (xpOption pickleSaslFeature) + (xpAll xpElemVerbatim) + ) + ) + where + pickleTLSFeature :: PU [Node] Bool + pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + (xpElemExists "required") + pickleSaslFeature :: PU [Node] [Text] + pickleSaslFeature = xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + (xpAll $ xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId)) \ No newline at end of file diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 0013bcf..c74c251 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Network.XMPP.TLS where @@ -18,58 +18,58 @@ import Network.XMPP.Stream import Network.XMPP.Types starttlsE :: Element -starttlsE = - Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] +starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] exampleParams :: TLS.TLSParams exampleParams = TLS.defaultParams - {pConnectVersion = TLS.TLS10 - , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] - , pCiphers = [TLS.cipher_AES128_SHA1] - , pCompressions = [TLS.nullCompression] - , pWantClientCert = False -- Used for servers - , pUseSecureRenegotiation = False -- No renegotiation - , pCertificates = [] -- TODO - , pLogging = TLS.defaultLogging -- TODO - , onCertificatesRecv = \ _certificate -> - return TLS.CertificateUsageAccept - } + { pConnectVersion = TLS.TLS10 + , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] + , pCiphers = [TLS.cipher_AES128_SHA1] + , pCompressions = [TLS.nullCompression] + , pWantClientCert = False -- Used for servers + , pUseSecureRenegotiation = False -- No renegotiation + , pCertificates = [] -- TODO + , pLogging = TLS.defaultLogging -- TODO + , onCertificatesRecv = \_certificate -> + return TLS.CertificateUsageAccept + } -- | Error conditions that may arise during TLS negotiation. data XMPPTLSError = TLSError TLSError | TLSNoServerSupport | TLSNoConnection | TLSStreamError StreamError + | XMPPTLSError -- General instance used for the Error instance deriving (Show, Eq, Typeable) instance Error XMPPTLSError where - noMsg = TLSNoConnection -- TODO: What should we choose here? + noMsg = XMPPTLSError +-- Pushes ", waits for "", performs the TLS handshake, and +-- restarts the stream. May throw errors. startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) -startTLS params = Ex.handle (return . Left . TLSError) - . runErrorT $ do - features <- lift $ gets sFeatures - handle' <- lift $ gets sConHandle - handle <- maybe (throwError TLSNoConnection) return handle' - when (stls features == Nothing) $ throwError TLSNoServerSupport - lift $ pushN starttlsE - answer <- lift $ pullElement - case answer of +startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do + features <- lift $ gets sFeatures + handle' <- lift $ gets sConHandle + handle <- maybe (throwError TLSNoConnection) return handle' + when (stls features == Nothing) $ throwError TLSNoServerSupport + lift $ pushElement starttlsE + answer <- lift $ pullElement + 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 - -- 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 --- , sConSrc = -- Note: this momentarily leaves us in an - -- inconsistent state - , sConPushBS = catchPush . psh - , sCloseConnection = TLS.bye ctx >> sCloseConnection x - }) - either (lift . Ex.throwIO) return =<< lift xmppRestartStream - modify (\s -> s{sConnectionState = XmppConnectionSecured}) - return () - + 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 +-- , sConSrc = -- Note: this momentarily leaves us in an + -- inconsistent state + , sConPushBS = catchPush . psh + , sCloseConnection = TLS.bye ctx >> sCloseConnection x + }) + either (lift . Ex.throwIO) return =<< lift xmppRestartStream + modify (\s -> s{sConnectionState = XmppConnectionSecured}) + return () \ No newline at end of file