Supporting TLS 1.3 draft 18.

See: haskell-tls#167

This jumbo patch will be eventually divided into logical patches
after standardization of TLS 1.3 is finished and before a pull request
is sent. This patch is jumbo to observe the entire patch to make
difference minimum. This patch is repeatedly rebased and overridden
to clean up the TLS 1.3 code. Take care.

core/Network/TLS/Cipher.hs

@@ -95,6 +95,7 @@ data CipherKeyExchangeType =
     | CipherKeyExchange_ECDH_ECDSA
     | CipherKeyExchange_ECDH_RSA
     | CipherKeyExchange_ECDHE_ECDSA
+    | CipherKeyExchange_TLS13 -- not expressed in cipher suite
     deriving (Show,Eq)
 
 data Bulk = Bulk
@@ -156,3 +157,4 @@ cipherExchangeNeedMoreData CipherKeyExchange_DH_RSA      = False
 cipherExchangeNeedMoreData CipherKeyExchange_ECDH_ECDSA  = True
 cipherExchangeNeedMoreData CipherKeyExchange_ECDH_RSA    = True
 cipherExchangeNeedMoreData CipherKeyExchange_ECDHE_ECDSA = True
+cipherExchangeNeedMoreData CipherKeyExchange_TLS13       = False -- dummy

core/Network/TLS/Context.hs

@@ -14,6 +14,7 @@ module Network.TLS.Context
     -- * Context object and accessor
     , Context(..)
     , Hooks(..)
+    , Established(..)
     , ctxEOF
     , ctxHasSSLv2ClientHello
     , ctxDisableSSLv2ClientHello
@@ -60,6 +61,7 @@ module Network.TLS.Context
     , usingHState
     , getHState
     , getStateRNG
+    , tls13orLater
     ) where
 
 import Network.TLS.Backend
@@ -133,6 +135,7 @@ instance TLSParams ServerParams where
                         CipherKeyExchange_DH_RSA      -> False
                         CipherKeyExchange_ECDH_ECDSA  -> False
                         CipherKeyExchange_ECDH_RSA    -> False
+                        CipherKeyExchange_TLS13       -> True   -- dirty hack
 
                 canDHE        = isJust $ serverDHEParams sparams
                 canSignDSS    = DSS `elem` signingAlgs
@@ -171,7 +174,7 @@ contextNew backend params = liftIO $ do
 
     stvar <- newMVar st
     eof   <- newIORef False
-    established <- newIORef False
+    established <- newIORef NotEstablished
     stats <- newIORef newMeasurement
     -- we enable the reception of SSLv2 ClientHello message only in the
     -- server context, where we might be dealing with an old/compat client.
@@ -181,6 +184,7 @@ contextNew backend params = liftIO $ do
     tx    <- newMVar newRecordState
     rx    <- newMVar newRecordState
     hs    <- newMVar Nothing
+    as    <- newMVar []
     lockWrite <- newMVar ()
     lockRead  <- newMVar ()
     lockState <- newMVar ()
@@ -205,6 +209,7 @@ contextNew backend params = liftIO $ do
             , ctxLockWrite        = lockWrite
             , ctxLockRead         = lockRead
             , ctxLockState        = lockState
+            , ctxPendingActions   = as
             }
 
 -- | create a new context on an handle.

core/Network/TLS/Context/Internal.hs

@@ -19,6 +19,7 @@ module Network.TLS.Context.Internal
     -- * Context object and accessor
     , Context(..)
     , Hooks(..)
+    , Established(..)
     , ctxEOF
     , ctxHasSSLv2ClientHello
     , ctxDisableSSLv2ClientHello
@@ -52,6 +53,7 @@ module Network.TLS.Context.Internal
     , usingHState
     , getHState
     , getStateRNG
+    , tls13orLater
     ) where
 
 import Network.TLS.Backend
@@ -95,7 +97,7 @@ data Context = Context
     , ctxState            :: MVar TLSState
     , ctxMeasurement      :: IORef Measurement
     , ctxEOF_             :: IORef Bool    -- ^ has the handle EOFed or not.
-    , ctxEstablished_     :: IORef Bool    -- ^ has the handshake been done and been successful.
+    , ctxEstablished_     :: IORef Established  -- ^ has the handshake been done and been successful.
     , ctxNeedEmptyPacket  :: IORef Bool    -- ^ empty packet workaround for CBC guessability.
     , ctxSSLv2ClientHello :: IORef Bool    -- ^ enable the reception of compatibility SSLv2 client hello.
                                            -- the flag will be set to false regardless of its initial value
@@ -110,8 +112,15 @@ data Context = Context
     , ctxLockRead         :: MVar ()       -- ^ lock to use for reading data (including updating the state)
     , ctxLockState        :: MVar ()       -- ^ lock used during read/write when receiving and sending packet.
                                            -- it is usually nested in a write or read lock.
+    , ctxPendingActions   :: MVar [Bytes -> IO ()]
     }
 
+data Established = NotEstablished
+                 | EarlyDataAllowed
+                 | EarlyDataNotAllowed
+                 | Established
+                 deriving (Eq, Show)
+
 updateMeasure :: Context -> (Measurement -> Measurement) -> IO ()
 updateMeasure ctx f = do
     x <- readIORef (ctxMeasurement ctx)
@@ -159,7 +168,7 @@ ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False
 setEOF :: Context -> IO ()
 setEOF ctx = writeIORef (ctxEOF_ ctx) True
 
-ctxEstablished :: Context -> IO Bool
+ctxEstablished :: Context -> IO Established
 ctxEstablished ctx = readIORef $ ctxEstablished_ ctx
 
 ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a
@@ -168,7 +177,7 @@ ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f
 contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()
 contextModifyHooks ctx f = modifyIORef (ctxHooks ctx) f
 
-setEstablished :: Context -> Bool -> IO ()
+setEstablished :: Context -> Established -> IO ()
 setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v
 
 withLog :: Context -> (Logging -> IO ()) -> IO ()
@@ -205,8 +214,11 @@ getHState ctx = liftIO $ readMVar (ctxHandshake ctx)
 runTxState :: Context -> RecordM a -> IO (Either TLSError a)
 runTxState ctx f = do
     ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)
+    let ver'
+         | ver >= TLS13ID18 = TLS10
+         | otherwise        = ver
     modifyMVar (ctxTxState ctx) $ \st ->
-        case runRecordM f ver st of
+        case runRecordM f ver' st of
             Left err         -> return (st, Left err)
             Right (a, newSt) -> return (newSt, Right a)
 
@@ -232,3 +244,10 @@ withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f
 
 withStateLock :: Context -> IO a -> IO a
 withStateLock ctx f = withMVar (ctxLockState ctx) (const f)
+
+tls13orLater :: MonadIO m => Context -> m Bool
+tls13orLater ctx = do
+    ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS10 -- fixme
+    return $ case ev of
+               Left  _ -> False
+               Right v -> v >= TLS13ID18

core/Network/TLS/Core.hs

@@ -31,11 +31,16 @@ module Network.TLS.Core
 
 import Network.TLS.Context
 import Network.TLS.Struct
+import Network.TLS.Struct13
 import Network.TLS.State (getSession)
 import Network.TLS.Parameters
 import Network.TLS.IO
 import Network.TLS.Session
 import Network.TLS.Handshake
+import Network.TLS.Handshake.Common
+import Network.TLS.Handshake.Common13
+import Network.TLS.Handshake.State
+import Network.TLS.Handshake.State13
 import Network.TLS.Util (catchException)
 import qualified Network.TLS.State as S
 import qualified Data.ByteString as B
@@ -45,14 +50,18 @@ import qualified Control.Exception as E
 
 import Control.Monad.State.Strict
 
-
 -- | notify the context that this side wants to close connection.
 -- this is important that it is called before closing the handle, otherwise
 -- the session might not be resumable (for version < TLS1.2).
 --
 -- this doesn't actually close the handle
 bye :: MonadIO m => Context -> m ()
-bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]
+bye ctx = do
+    tls13 <- tls13orLater ctx
+    if tls13 then
+        sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)]
+      else
+        sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]
 
 -- | If the ALPN extensions have been used, this will
 -- return get the protocol agreed upon.
@@ -69,58 +78,113 @@ getClientSNI ctx = liftIO $ usingState_ ctx S.getClientSNI
 -- | sendData sends a bunch of data.
 -- It will automatically chunk data to acceptable packet size
 sendData :: MonadIO m => Context -> L.ByteString -> m ()
-sendData ctx dataToSend = liftIO (checkValid ctx) >> mapM_ sendDataChunk (L.toChunks dataToSend)
-  where sendDataChunk d
+sendData ctx dataToSend = do
+    tls13 <- tls13orLater ctx
+    let sendP
+          | tls13     = sendPacket13 ctx . AppData13
+          | otherwise = sendPacket ctx . AppData
+    let sendDataChunk d
             | B.length d > 16384 = do
                 let (sending, remain) = B.splitAt 16384 d
-                sendPacket ctx $ AppData sending
+                sendP sending
                 sendDataChunk remain
-            | otherwise = sendPacket ctx $ AppData d
+            | otherwise = sendP d
+    liftIO (checkValid ctx) >> mapM_ sendDataChunk (L.toChunks dataToSend)
 
 -- | recvData get data out of Data packet, and automatically renegotiate if
 -- a Handshake ClientHello is received
 recvData :: MonadIO m => Context -> m B.ByteString
-recvData ctx = liftIO $ do
+recvData ctx = do
+    tls13 <- tls13orLater ctx
+    if tls13 then recvData13 ctx else recvData1 ctx
+
+recvData1 :: MonadIO m => Context -> m B.ByteString
+recvData1 ctx = liftIO $ do
     checkValid ctx
     pkt <- withReadLock ctx $ recvPacket ctx
-    either onError process pkt
-  where onError Error_EOF = -- Not really an error.
-            return B.empty
-
-        onError err@(Error_Protocol (reason,fatal,desc)) =
-            terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason
-        onError err =
-            terminate err AlertLevel_Fatal InternalError (show err)
-
-        process (Handshake [ch@(ClientHello {})]) =
-            withRWLock ctx ((ctxDoHandshakeWith ctx) ctx ch) >> recvData ctx
+    either (onError terminate) process pkt
+  where process (Handshake [ch@(ClientHello {})]) =
+            withRWLock ctx ((ctxDoHandshakeWith ctx) ctx ch) >> recvData1 ctx
         process (Handshake [hr@HelloRequest]) =
-            withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hr) >> recvData ctx
+            withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hr) >> recvData1 ctx
 
-        process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> setEOF ctx >> return B.empty
+        process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty
         process (Alert [(AlertLevel_Fatal, desc)]) = do
             setEOF ctx
             E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc)))
 
         -- when receiving empty appdata, we just retry to get some data.
-        process (AppData "") = recvData ctx
+        process (AppData "") = recvData1 ctx
         process (AppData x)  = return x
         process p            = let reason = "unexpected message " ++ show p in
                                terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
 
-        terminate :: TLSError -> AlertLevel -> AlertDescription -> String -> IO a
-        terminate err level desc reason = do
-            session <- usingState_ ctx getSession
-            case session of
-                Session Nothing    -> return ()
-                Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid
-            catchException (sendPacket ctx $ Alert [(level, desc)]) (\_ -> return ())
+        terminate = terminate' ctx (\x -> sendPacket ctx $ Alert x)
+
+recvData13 :: MonadIO m => Context -> m B.ByteString
+recvData13 ctx = liftIO $ do
+    checkValid ctx
+    pkt <- withReadLock ctx $ recvPacket13 ctx
+    either (onError terminate) process pkt
+  where process (Alert13 [(_,EndOfEarlyData)]) = do
+            alertAction <- popPendingAction ctx
+            alertAction "dummy"
+            recvData13 ctx
+        process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty
+        process (Alert13 [(AlertLevel_Fatal, desc)]) = do
             setEOF ctx
-            E.throwIO (Terminated False reason err)
+            E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc)))
+        process (Handshake13 [ClientHello13 _ _ _ _]) = do
+            let reason = "Client hello is not allowed"
+            terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
+        process (Handshake13 [Finished13 verifyData']) = do
+            finishedAction <- popPendingAction ctx
+            finishedAction verifyData'
+            recvData13 ctx
+        process (Handshake13 [NewSessionTicket13 life add ticket _exts]) = do
+            mgrp <- usingHState ctx getTLS13Group
+            tinfo <- createTLS13TicketInfo life $ Right add
+            Just sdata <- getSessionData ctx mgrp (Just tinfo)
+            sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket sdata
+            putStrLn "NewSessionTicket received"
+            recvData13 ctx
+        -- when receiving empty appdata, we just retry to get some data.
+        process (AppData13 "") = recvData13 ctx
+        process (AppData13 x) = do
+            established <- ctxEstablished ctx
+            if established == EarlyDataNotAllowed then
+                recvData13 ctx
+              else
+                return x
+        process p             = let reason = "unexpected message " ++ show p in
+                                terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
+
+        terminate = terminate' ctx (\x -> sendPacket13 ctx $ Alert13 x)
+
+-- this in a try and ignore all exceptions
+tryBye :: Context -> IO ()
+tryBye ctx = catchException (bye ctx) (\_ -> return ())
+
+onError :: Monad m => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)
+                   -> TLSError -> m B.ByteString
+onError _ Error_EOF = -- Not really an error.
+            return B.empty
+onError terminate err@(Error_Protocol (reason,fatal,desc)) =
+    terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason
+onError terminate err =
+    terminate err AlertLevel_Fatal InternalError (show err)
+
+terminate' :: Context -> ([(AlertLevel, AlertDescription)] -> IO ())
+           -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a
+terminate' ctx send err level desc reason = do
+    session <- usingState_ ctx getSession
+    case session of
+        Session Nothing    -> return ()
+        Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid
+    catchException (send [(level, desc)]) (\_ -> return ())
+    setEOF ctx
+    E.throwIO (Terminated False reason err)
 
-        -- the other side could have close the connection already, so wrap
-        -- this in a try and ignore all exceptions
-        tryBye = catchException (bye ctx) (\_ -> return ())
 
 {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}
 -- | same as recvData but returns a lazy bytestring.

core/Network/TLS/Credentials.hs

@@ -15,6 +15,7 @@ module Network.TLS.Credentials
     , credentialsFindForSigning
     , credentialsFindForDecrypting
     , credentialsListSigningAlgorithms
+    , credentialCanSign -- fixme
     ) where
 
 import Data.Monoid