From 14eb3c686cf6fb6501041fd3ffdb217f8a7bfa61 Mon Sep 17 00:00:00 2001
From: Vincent Hanquez <vincent@snarc.org>
Date: Sun, 23 Mar 2014 06:07:25 +0000
Subject: [PATCH] Accept non-fatal UnrecognizedName alert after ClientHello.

Misconfigured servers send an "Unrecognized Name" warning in the SSL
handshake which is ignored by most clients. Some stack would fail the same
way (i.e. Java 7 with SNI enabled).

Improve state machine slightly.

Fix #53.
---
 core/Network/TLS/Handshake/Client.hs | 14 +++++++++++++-
 core/Network/TLS/Handshake/Common.hs | 20 +++++++++++---------
 core/Network/TLS/Handshake/Server.hs |  2 ++
 3 files changed, 26 insertions(+), 10 deletions(-)

diff --git a/core/Network/TLS/Handshake/Client.hs b/core/Network/TLS/Handshake/Client.hs
index 0c36170..65a3747 100644
--- a/core/Network/TLS/Handshake/Client.hs
+++ b/core/Network/TLS/Handshake/Client.hs
@@ -103,7 +103,19 @@ handshakeClient cparams ctx = do
                 -- client didn't offer. do nothing.
                 (Nothing, _) -> return ()
 
-        recvServerHello sentExts = runRecvState ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts)
+        recvServerHello sentExts = runRecvState ctx recvState
+          where recvState = RecvStateNext $ \p ->
+                    case p of
+                        Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) hs
+                        Alert a      ->
+                            case a of
+                                [(AlertLevel_Warning, UnrecognizedName)] ->
+                                    if clientUseServerNameIndication cparams
+                                        then return recvState
+                                        else throwAlert a
+                                _ -> throwAlert a
+                        _ -> fail ("unexepected type received. expecting handshake and got: " ++ show p)
+                throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure)
 
 -- | send client Data after receiving all server data (hello/certificates/key).
 --
diff --git a/core/Network/TLS/Handshake/Common.hs b/core/Network/TLS/Handshake/Common.hs
index 36a0e0a..9be9e67 100644
--- a/core/Network/TLS/Handshake/Common.hs
+++ b/core/Network/TLS/Handshake/Common.hs
@@ -12,6 +12,7 @@ module Network.TLS.Handshake.Common
     , RecvState(..)
     , runRecvState
     , recvPacketHandshake
+    , onRecvStateHandshake
     ) where
 
 import Control.Concurrent.MVar
@@ -98,18 +99,19 @@ recvPacketHandshake ctx = do
         Right x             -> fail ("unexpected type received. expecting handshake and got: " ++ show x)
         Left err            -> throwCore err
 
+-- | process a list of handshakes message in the recv state machine.
+onRecvStateHandshake :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
+onRecvStateHandshake _   recvState [] = return recvState
+onRecvStateHandshake ctx (RecvStateHandshake f) (x:xs) = do
+    nstate <- f x
+    processHandshake ctx x
+    onRecvStateHandshake ctx nstate xs
+onRecvStateHandshake _ _ _   = unexpected "spurious handshake" Nothing
+
 runRecvState :: Context -> RecvState IO -> IO ()
 runRecvState _   (RecvStateDone)   = return ()
 runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx
-runRecvState ctx iniState          = recvPacketHandshake ctx >>= loop iniState >>= runRecvState ctx
-  where
-        loop :: RecvState IO -> [Handshake] -> IO (RecvState IO)
-        loop recvState []                  = return recvState
-        loop (RecvStateHandshake f) (x:xs) = do
-            nstate <- f x
-            processHandshake ctx x
-            loop nstate xs
-        loop _                         _   = unexpected "spurious handshake" Nothing
+runRecvState ctx iniState          = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx
 
 getSessionData :: Context -> IO (Maybe SessionData)
 getSessionData ctx = do
diff --git a/core/Network/TLS/Handshake/Server.hs b/core/Network/TLS/Handshake/Server.hs
index a0f6ac1..a164035 100644
--- a/core/Network/TLS/Handshake/Server.hs
+++ b/core/Network/TLS/Handshake/Server.hs
@@ -288,6 +288,8 @@ recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientC
 
         processClientCertificate p = processClientKeyExchange p
 
+        -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,
+        -- so we must process any packet, and in case of handshake call processHandshake manually.
         processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
         processClientKeyExchange p                 = unexpected (show p) (Just "client key exchange")