reduced the TLS module to just the TLSParams and improved the TLS handshake code

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
+    tlsCtx <- lift $ liftIO $ do
-    let tlsCtx_ = fromJust tlsCtx
+        gen <- newGenIO :: IO SystemRandom -- TODO: Investigate limitations
-    put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state) (stateIDGenerator state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) }
+        clientContext <- client tlsParams gen handle
-    threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx_) -- double code
+        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
 

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 (
+module Network.XMPP.TLS (tlsParams) where
-getTLSParams,
-handshake'
-) 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)
 
-
+tlsParams :: TLSParams
-getTLSParams :: TLSParams
+tlsParams = TLSParams { pConnectVersion    = TLS10 -- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug?
-getTLSParams = TLSParams { pConnectVersion    = TLS10
+                      , pAllowedVersions   = [SSL3, TLS10,TLS11] -- TODO: TLS12 when supported in tls
-                         , pAllowedVersions   = [TLS10,TLS11]
+                      , pCiphers           = [cipher_AES128_SHA1] -- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA?
-                         , pCiphers           = [cipher_AES128_SHA1] -- Check the rest
+                      , pCompressions      = [nullCompression] -- TODO
-                         , pCompressions      = [nullCompression]
+                      , pWantClientCert    = False -- Used for servers
-                         , pWantClientCert    = False
+                      , pUseSecureRenegotiation = False -- TODO: No renegotiation!
-                         , pUseSecureRenegotiation = False -- TODO: No renegotiation
+                      , pCertificates      = [] -- TODO
-                         , pCertificates      = []
+                      , pLogging           = defaultLogging -- TODO
-                         , pLogging           = defaultLogging
+                      , onCertificatesRecv = \_ -> return CertificateUsageAccept } -- TODO
-                         , 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)