module Network.Xmpp.TLS where
import qualified Control.Exception.Lifted as Ex
import Control.Monad
import Control.Monad.Error
import Control.Monad.State.Strict
import Data.Conduit.TLS as TLS
import Data.Typeable
import Data.XML.Types
import Network.Xmpp.Monad
import Network.Xmpp.Pickle(ppElement)
import Network.Xmpp.Stream
import Network.Xmpp.Types
starttlsE :: Element
starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
exampleParams :: TLS.TLSParams
exampleParams = TLS.defaultParamsClient
{ pConnectVersion = TLS.TLS10
, pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11]
, pCiphers = [TLS.cipher_AES128_SHA1]
, pCompressions = [TLS.nullCompression]
, pUseSecureRenegotiation = False
, onCertificatesRecv = \_certificate ->
return TLS.CertificateUsageAccept
}
data XmppTLSError = TLSError TLSError
| TLSNoServerSupport
| TLSNoConnection
| TLSStreamError StreamError
| XmppTLSError
deriving (Show, Eq, Typeable)
instance Error XmppTLSError where
noMsg = XmppTLSError
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 $ 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
e -> lift . Ex.throwIO . StreamXMLError $
"Unexpected element: " ++ ppElement e
(raw, _snk, psh, ctx) <- lift $ TLS.tlsinit debug params handle
lift $ modify ( \x -> x
{ sRawSrc = raw
, sConPushBS = catchPush . psh
, sCloseConnection = TLS.bye ctx >> sCloseConnection x
})
either (lift . Ex.throwIO) return =<< lift xmppRestartStream
modify (\s -> s{sConnectionState = XmppConnectionSecured})
return ()