From e4d8a42c6f1fc9ed553165bf1a1f1e4328f3f77a Mon Sep 17 00:00:00 2001
From: Jon Kristensen <info@jonkristensen.com>
Date: Wed, 13 Jul 2011 00:37:01 +0200
Subject: [PATCH] reduced the TLS module to just the TLSParams and improved the
 TLS handshake code

---
 Network/XMPP/Session.hs | 15 ++++++++++-----
 Network/XMPP/TLS.hs     | 36 +++++++++++-------------------------
 2 files changed, 21 insertions(+), 30 deletions(-)

diff --git a/Network/XMPP/Session.hs b/Network/XMPP/Session.hs
index 0201252..a2139c2 100644
--- a/Network/XMPP/Session.hs
+++ b/Network/XMPP/Session.hs
@@ -83,6 +83,8 @@ import qualified Network as N
 
 -------------
 
+import Crypto.Random (newGenIO, SystemRandom)
+
 import Control.Concurrent.MVar
 
 import Codec.Binary.UTF8.String
@@ -489,10 +491,13 @@ processEvent e = get >>= \ state ->
   -- might not have exited?
   IEE (EnumeratorXML XEProceed) -> do
     let Connected (ServerAddress hostName _) handle = stateConnectionState state
-    tlsCtx <- lift $ liftIO $ handshake' handle hostName
-    let tlsCtx_ = fromJust tlsCtx
-    put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) }
-    threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx_) -- double code
+    tlsCtx <- lift $ liftIO $ do
+        gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations
+        clientContext <- client tlsParams gen handle
+        handshake clientContext
+        return clientContext
+    put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) }
+    threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx) -- double code
     lift $ liftIO $ putStrLn "00000000000000000000000000000000"
     lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used
     lift $ liftIO $ putStrLn "00000000000000000000000000000000"
@@ -500,7 +505,7 @@ processEvent e = get >>= \ state ->
     lift $ liftIO $ putStrLn "00000000000000000000000000000000"
     lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++
       hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
-      "streams' version='1.0'>") (Right tlsCtx_)
+      "streams' version='1.0'>") (Right tlsCtx)
     lift $ liftIO $ putStrLn "00000000000000000000000000000000"
     return Nothing
 
diff --git a/Network/XMPP/TLS.hs b/Network/XMPP/TLS.hs
index ee569ef..4f57321 100644
--- a/Network/XMPP/TLS.hs
+++ b/Network/XMPP/TLS.hs
@@ -22,34 +22,20 @@ with Pontarius XMPP. If not, see <http://www.gnu.org/licenses/>.
 
 {-# OPTIONS_HADDOCK hide #-}
 
-module Network.XMPP.TLS (
-getTLSParams,
-handshake'
-) where
+module Network.XMPP.TLS (tlsParams) where
 
-import Crypto.Random (newGenIO, SystemRandom)
 import Network.TLS
 import Network.TLS.Extra (cipher_AES128_SHA1)
 import Network.TLS.Cipher
 import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
 
-
-getTLSParams :: TLSParams
-getTLSParams = TLSParams { pConnectVersion    = TLS10
-                         , pAllowedVersions   = [TLS10,TLS11]
-                         , pCiphers           = [cipher_AES128_SHA1] -- Check the rest
-                         , pCompressions      = [nullCompression]
-                         , pWantClientCert    = False
-                         , pUseSecureRenegotiation = False -- TODO: No renegotiation
-                         , pCertificates      = []
-                         , pLogging           = defaultLogging
-                         , onCertificatesRecv = \_ -> return CertificateUsageAccept } -- Verify cert chain
-
-handshake' :: Handle -> String -> IO (Maybe TLSCtx)
-handshake' h s = do
-  let t = getTLSParams
-  r <- newGenIO :: IO SystemRandom -- Investigate limitations
-  c <- client t r h
-  handshake c
-  putStrLn ">>>>TLS data sended<<<<"
-  return (Just c)
+tlsParams :: TLSParams
+tlsParams = TLSParams { pConnectVersion    = TLS10 -- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug?
+                      , pAllowedVersions   = [SSL3, TLS10,TLS11] -- TODO: TLS12 when supported in tls
+                      , pCiphers           = [cipher_AES128_SHA1] -- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA?
+                      , pCompressions      = [nullCompression] -- TODO
+                      , pWantClientCert    = False -- Used for servers
+                      , pUseSecureRenegotiation = False -- TODO: No renegotiation!
+                      , pCertificates      = [] -- TODO
+                      , pLogging           = defaultLogging -- TODO
+                      , onCertificatesRecv = \_ -> return CertificateUsageAccept } -- TODO