diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 0013bcf..21e49c9 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 $ pushN 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