From 9296c3003d0ca418e45d30fec4700aa690fcc425 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 21 Dec 2016 11:26:38 +0900 Subject: [PATCH] Supporting TLS 1.3 draft 18. See: https://github.com/vincenthz/hs-tls/issues/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 | 2 + core/Network/TLS/Context.hs | 7 +- core/Network/TLS/Context/Internal.hs | 27 +- core/Network/TLS/Core.hs | 128 ++++++-- core/Network/TLS/Credentials.hs | 1 + core/Network/TLS/Extension.hs | 206 ++++++++++++- core/Network/TLS/Extra/Cipher.hs | 38 ++- core/Network/TLS/Handshake.hs | 9 +- core/Network/TLS/Handshake/Client.hs | 370 ++++++++++++++++++++--- core/Network/TLS/Handshake/Common.hs | 20 +- core/Network/TLS/Handshake/Common13.hs | 232 +++++++++++++++ core/Network/TLS/Handshake/Process.hs | 18 +- core/Network/TLS/Handshake/Server.hs | 379 +++++++++++++++++++++--- core/Network/TLS/Handshake/Signature.hs | 13 + core/Network/TLS/Handshake/State.hs | 83 +++++- core/Network/TLS/Handshake/State13.hs | 82 +++++ core/Network/TLS/IO.hs | 51 +++- core/Network/TLS/KeySchedule.hs | 62 ++++ core/Network/TLS/Packet.hs | 66 ++++- core/Network/TLS/Packet13.hs | 125 ++++++++ core/Network/TLS/Parameters.hs | 7 +- core/Network/TLS/Receiving13.hs | 45 +++ core/Network/TLS/Record/Disengage13.hs | 78 +++++ core/Network/TLS/Record/Engage13.hs | 64 ++++ core/Network/TLS/Record/Types13.hs | 20 ++ core/Network/TLS/Sending13.hs | 65 ++++ core/Network/TLS/State.hs | 7 +- core/Network/TLS/Struct.hs | 43 ++- core/Network/TLS/Struct13.hs | 106 +++++++ core/Network/TLS/Types.hs | 18 +- core/Network/TLS/Wire.hs | 8 + core/tls.cabal | 11 + debug/src/SimpleClient.hs | 56 +++- debug/src/SimpleServer.hs | 5 +- 34 files changed, 2257 insertions(+), 195 deletions(-) create mode 100644 core/Network/TLS/Handshake/Common13.hs create mode 100644 core/Network/TLS/Handshake/State13.hs create mode 100644 core/Network/TLS/KeySchedule.hs create mode 100644 core/Network/TLS/Packet13.hs create mode 100644 core/Network/TLS/Receiving13.hs create mode 100644 core/Network/TLS/Record/Disengage13.hs create mode 100644 core/Network/TLS/Record/Engage13.hs create mode 100644 core/Network/TLS/Record/Types13.hs create mode 100644 core/Network/TLS/Sending13.hs create mode 100644 core/Network/TLS/Struct13.hs diff --git a/core/Network/TLS/Cipher.hs b/core/Network/TLS/Cipher.hs index 4b3b7a965..c92eb3db0 100644 --- a/core/Network/TLS/Cipher.hs +++ b/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 diff --git a/core/Network/TLS/Context.hs b/core/Network/TLS/Context.hs index 2ba083cf4..da41b5ee1 100644 --- a/core/Network/TLS/Context.hs +++ b/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. diff --git a/core/Network/TLS/Context/Internal.hs b/core/Network/TLS/Context/Internal.hs index 483fa3272..6844c758a 100644 --- a/core/Network/TLS/Context/Internal.hs +++ b/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 @@ -96,7 +98,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 @@ -111,8 +113,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 [ByteString -> IO ()] } +data Established = NotEstablished + | EarlyDataAllowed + | EarlyDataNotAllowed + | Established + deriving (Eq, Show) + updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx f = do x <- readIORef (ctxMeasurement ctx) @@ -160,7 +169,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 @@ -169,7 +178,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 () @@ -206,8 +215,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) @@ -233,3 +245,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 diff --git a/core/Network/TLS/Core.hs b/core/Network/TLS/Core.hs index dcf9f190d..f24753ff8 100644 --- a/core/Network/TLS/Core.hs +++ b/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. diff --git a/core/Network/TLS/Credentials.hs b/core/Network/TLS/Credentials.hs index 15f047765..ea6af4a5a 100644 --- a/core/Network/TLS/Credentials.hs +++ b/core/Network/TLS/Credentials.hs @@ -15,6 +15,7 @@ module Network.TLS.Credentials , credentialsFindForSigning , credentialsFindForDecrypting , credentialsListSigningAlgorithms + , credentialCanSign -- fixme ) where import Data.ByteString (ByteString) diff --git a/core/Network/TLS/Extension.hs b/core/Network/TLS/Extension.hs index 1e5facc15..6e3e736bc 100644 --- a/core/Network/TLS/Extension.hs +++ b/core/Network/TLS/Extension.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} -- | -- Module : Network.TLS.Extension -- License : BSD-style @@ -20,6 +21,13 @@ module Network.TLS.Extension , extensionID_EcPointFormats , extensionID_Heartbeat , extensionID_SignatureAlgorithms + , extensionID_KeyShare + , extensionID_PreSharedKey + , extensionID_EarlyData + , extensionID_SupportedVersions + , extensionID_Cookie + , extensionID_PskKeyExchangeModes + , extensionID_TicketEarlyDataInfo -- all implemented extensions , ServerNameType(..) , ServerName(..) @@ -35,10 +43,18 @@ module Network.TLS.Extension , HeartBeat(..) , HeartBeatMode(..) , SignatureAlgorithms(..) + , SupportedVersions(..) + , KeyShare(..) + , KeyShareEntry(..) + , MessageType(..) + , PskKexMode(..) + , PskKeyExchangeModes(..) + , PskIdentity(..) + , PreSharedKey(..) + , EarlyDataIndication(..) + , TicketEarlyDataInfo(..) ) where -import Control.Monad - import Data.Word import Data.Maybe (fromMaybe, catMaybes) import Data.ByteString (ByteString) @@ -47,9 +63,11 @@ import qualified Data.ByteString.Char8 as BC import Network.TLS.Struct (ExtensionID, EnumSafe8(..), EnumSafe16(..), HashAndSignatureAlgorithm) import Network.TLS.Crypto.Types +import Network.TLS.Types (Version(..)) + import Network.TLS.Wire import Network.TLS.Imports -import Network.TLS.Packet (putSignatureHashAlgorithm, getSignatureHashAlgorithm) +import Network.TLS.Packet (putSignatureHashAlgorithm, getSignatureHashAlgorithm, putVersion', getVersion') type HostName = String @@ -79,6 +97,13 @@ extensionID_ServerName , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket + , extensionID_KeyShare + , extensionID_PreSharedKey + , extensionID_EarlyData + , extensionID_SupportedVersions + , extensionID_Cookie + , extensionID_PskKeyExchangeModes + , extensionID_TicketEarlyDataInfo , extensionID_SecureRenegotiation :: ExtensionID extensionID_ServerName = 0x0 -- RFC6066 extensionID_MaxFragmentLength = 0x1 -- RFC6066 @@ -93,7 +118,7 @@ extensionID_CertType = 0x9 -- RFC6091 extensionID_NegotiatedGroups = 0xa -- RFC4492bis and TLS 1.3 extensionID_EcPointFormats = 0xb -- RFC4492 extensionID_SRP = 0xc -- RFC5054 -extensionID_SignatureAlgorithms = 0xd -- RFC5246 +extensionID_SignatureAlgorithms = 0xd -- RFC5246, TLS 1.3 extensionID_SRTP = 0xe -- RFC5764 extensionID_Heartbeat = 0xf -- RFC6520 extensionID_ApplicationLayerProtocolNegotiation = 0x10 -- RFC7301 @@ -105,6 +130,13 @@ extensionID_Padding = 0x15 -- draft-agl-tls-padding. extensionID_EncryptThenMAC = 0x16 -- RFC7366 extensionID_ExtendedMasterSecret = 0x17 -- draft-ietf-tls-session-hash. expires 2015-09-26 extensionID_SessionTicket = 0x23 -- RFC4507 +extensionID_KeyShare = 0x28 -- TLS 1.3 +extensionID_PreSharedKey = 0x29 -- TLS 1.3 +extensionID_EarlyData = 0x2a -- TLS 1.3 +extensionID_SupportedVersions = 0x2b -- TLS 1.3 +extensionID_Cookie = 0x2c -- TLS 1.3 +extensionID_PskKeyExchangeModes = 0x2d -- TLS 1.3 +extensionID_TicketEarlyDataInfo = 0x2e -- TLS 1.3 extensionID_SecureRenegotiation = 0xff01 -- RFC5746 definedExtensions :: [ExtensionID] @@ -146,12 +178,24 @@ supportedExtensions = [ extensionID_ServerName , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SignatureAlgorithms + , extensionID_KeyShare + , extensionID_PreSharedKey + , extensionID_EarlyData + , extensionID_SupportedVersions + , extensionID_Cookie + , extensionID_PskKeyExchangeModes + , extensionID_TicketEarlyDataInfo ] +data MessageType = MsgTClientHello + | MsgTServerHello + | MsgTHelloRetryRequest + deriving (Eq,Show) + -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where extensionID :: a -> ExtensionID - extensionDecode :: Bool -> ByteString -> Maybe a + extensionDecode :: MessageType -> ByteString -> Maybe a extensionEncode :: a -> ByteString -- | Server Name extension including the name type and the associated name. @@ -205,12 +249,13 @@ instance Extension SecureRenegotiation where extensionID _ = extensionID_SecureRenegotiation extensionEncode (SecureRenegotiation cvd svd) = runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty svd) - extensionDecode isServerHello = runGetMaybe $ do + extensionDecode msgtype = runGetMaybe $ do opaque <- getOpaque8 - if isServerHello - then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque - in return $ SecureRenegotiation cvd (Just svd) - else return $ SecureRenegotiation opaque Nothing + case msgtype of + MsgTServerHello -> let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque + in return $ SecureRenegotiation cvd (Just svd) + MsgTClientHello -> return $ SecureRenegotiation opaque Nothing + _ -> error "decoding SecureRenegotiation for HRR" -- | Application Layer Protocol Negotiation (ALPN) data ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] @@ -308,3 +353,144 @@ instance Extension SignatureAlgorithms where runGetMaybe $ do len <- getWord16 SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + +data SupportedVersions = SupportedVersions [Version] + deriving (Show,Eq) + +instance Extension SupportedVersions where + extensionID _ = extensionID_SupportedVersions + extensionEncode (SupportedVersions vers) = runPut $ do + putWord8 (fromIntegral (length vers * 2)) + mapM_ putVersion' vers + extensionDecode _ = runGetMaybe $ do + len <- fromIntegral <$> getWord8 + SupportedVersions . catMaybes <$> getList len getVer + where + getVer = do + ver <- getVersion' + return (2,ver) + +data KeyShareEntry = KeyShareEntry { + keyShareEntryGroup :: Group + , keySHareEntryKeyExchange:: ByteString + }deriving (Show,Eq) + +getKeyShareEntry :: Get (Int, Maybe KeyShareEntry) +getKeyShareEntry = do + g <- getWord16 + l <- fromIntegral <$> getWord16 + key <- getBytes l + let !len = l + 4 + case toEnumSafe16 g of + Nothing -> return (len, Nothing) + Just grp -> return (len, Just $ KeyShareEntry grp key) + +putKeyShareEntry :: KeyShareEntry -> Put +putKeyShareEntry (KeyShareEntry grp key) = do + putWord16 $ fromEnumSafe16 grp + putWord16 $ fromIntegral $ B.length key + putBytes key + +data KeyShare = + KeyShareClientHello [KeyShareEntry] + | KeyShareServerHello KeyShareEntry + | KeyShareHRR Group + deriving (Show,Eq) + +instance Extension KeyShare where + extensionID _ = extensionID_KeyShare + extensionEncode (KeyShareClientHello kses) = runPut $ do + let !len = sum $ map (\(KeyShareEntry _ key) -> B.length key + 4) kses + putWord16 $ fromIntegral len + mapM_ putKeyShareEntry kses + extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse + extensionEncode (KeyShareHRR grp) = runPut $ putWord16 $ fromEnumSafe16 grp + extensionDecode MsgTServerHello = runGetMaybe $ do + (_, ment) <- getKeyShareEntry + case ment of + Nothing -> fail "decoding KeyShare for ServerHello" + Just ent -> return $ KeyShareServerHello ent + extensionDecode MsgTClientHello = runGetMaybe $ do + len <- fromIntegral <$> getWord16 + grps <- getList len getKeyShareEntry + return $ KeyShareClientHello $ catMaybes grps + extensionDecode MsgTHelloRetryRequest = runGetMaybe $ do + mgrp <- toEnumSafe16 <$> getWord16 + case mgrp of + Nothing -> fail "decoding KeyShare for HRR" + Just grp -> return $ KeyShareHRR grp + +data PskKexMode = PSK_KE | PSK_DHE_KE deriving (Eq, Show) + +fromPskKexMode :: PskKexMode -> Word8 +fromPskKexMode PSK_KE = 0 +fromPskKexMode PSK_DHE_KE = 1 + +toPskKexMode :: Word8 -> Maybe PskKexMode +toPskKexMode 0 = Just PSK_KE +toPskKexMode 1 = Just PSK_DHE_KE +toPskKexMode _ = Nothing + +data PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode] deriving (Eq, Show) + +instance Extension PskKeyExchangeModes where + extensionID _ = extensionID_PskKeyExchangeModes + extensionEncode (PskKeyExchangeModes pkms) = runPut $ + putWords8 $ map fromPskKexMode pkms + extensionDecode _ = runGetMaybe $ + PskKeyExchangeModes . catMaybes . map toPskKexMode <$> getWords8 + + +data PskIdentity = PskIdentity ByteString Word32 deriving (Eq, Show) + +data PreSharedKey = + PreSharedKeyClientHello [PskIdentity] [ByteString] + | PreSharedKeyServerHello Int + deriving (Eq, Show) + +instance Extension PreSharedKey where + extensionID _ = extensionID_PreSharedKey + extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do + putOpaque16 $ runPut (mapM_ putIdentity ids) + putOpaque16 $ runPut (mapM_ putBinder bds) + where + putIdentity (PskIdentity bs w) = do + putOpaque16 bs + putWord32 w + putBinder = putOpaque8 + extensionEncode (PreSharedKeyServerHello w16) = runPut $ + putWord16 $ fromIntegral w16 + extensionDecode MsgTServerHello = runGetMaybe $ + PreSharedKeyServerHello . fromIntegral <$> getWord16 + extensionDecode MsgTClientHello = runGetMaybe $ do + len1 <- fromIntegral <$> getWord16 + identities <- getList len1 getIdentity + len2 <- fromIntegral <$> getWord16 + binders <- getList len2 getBinder + return $ PreSharedKeyClientHello identities binders + where + getIdentity = do + identity <- getOpaque16 + age <- getWord32 + let len = 2 + B.length identity + 4 + return (len, PskIdentity identity age) + getBinder = do + l <- fromIntegral <$> getWord8 + binder <- getBytes l + let len = l + 1 + return (len, binder) + extensionDecode _ = error "decoding PreShareKey" + +data EarlyDataIndication = EarlyDataIndication deriving (Eq, Show) + +instance Extension EarlyDataIndication where + extensionID _ = extensionID_EarlyData + extensionEncode EarlyDataIndication = runPut $ putBytes B.empty + extensionDecode _ = return $ Just EarlyDataIndication + +data TicketEarlyDataInfo = TicketEarlyDataInfo Word32 deriving (Eq, Show) + +instance Extension TicketEarlyDataInfo where + extensionID _ = extensionID_TicketEarlyDataInfo + extensionEncode (TicketEarlyDataInfo w) = runPut $ putWord32 w + extensionDecode _ = runGetMaybe $ TicketEarlyDataInfo <$> getWord32 diff --git a/core/Network/TLS/Extra/Cipher.hs b/core/Network/TLS/Extra/Cipher.hs index bb7d0d3dc..0791ece01 100644 --- a/core/Network/TLS/Extra/Cipher.hs +++ b/core/Network/TLS/Extra/Cipher.hs @@ -44,6 +44,10 @@ module Network.TLS.Extra.Cipher , cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_ECDSA_AES128GCM_SHA256 , cipher_ECDHE_ECDSA_AES256GCM_SHA384 + -- TLS 1.3 + , cipher_TLS13_AES128GCM_SHA256 + , cipher_TLS13_AES256GCM_SHA384 + , cipherIDtoCipher13 -- * obsolete and non-standard ciphers , cipher_RSA_3DES_EDE_CBC_SHA1 , cipher_RC4_128_MD5 @@ -172,6 +176,8 @@ ciphersuite_default = -- , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 -- , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5 -- , cipher_RSA_3DES_EDE_CBC_SHA1 + , cipher_TLS13_AES128GCM_SHA256 + , cipher_TLS13_AES256GCM_SHA384 ] {-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-} @@ -213,6 +219,8 @@ ciphersuite_strong = , cipher_AES256_SHA256 -- Last resort no PFS, AEAD or SHA2 , cipher_AES256_SHA1 + , cipher_TLS13_AES128GCM_SHA256 + , cipher_TLS13_AES256GCM_SHA384 ] -- | DHE-RSA cipher suite @@ -523,6 +531,28 @@ cipher_DHE_RSA_AES256GCM_SHA384 = Cipher , cipherMinVer = Just TLS12 } +cipher_TLS13_AES128GCM_SHA256 :: Cipher +cipher_TLS13_AES128GCM_SHA256 = Cipher + { cipherID = 0x1301 + , cipherName = "AES128GCM-SHA256" + , cipherBulk = bulk_aes128gcm + , cipherHash = SHA256 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_TLS13 + , cipherMinVer = Just TLS13ID18 + } + +cipher_TLS13_AES256GCM_SHA384 :: Cipher +cipher_TLS13_AES256GCM_SHA384 = Cipher + { cipherID = 0x1302 + , cipherName = "AES256GCM-SHA384" + , cipherBulk = bulk_aes256gcm + , cipherHash = SHA384 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_TLS13 + , cipherMinVer = Just TLS13ID18 + } + cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES128CBC_SHA = Cipher { cipherID = 0xC009 @@ -655,5 +685,9 @@ cipher_ECDHE_RSA_AES256GCM_SHA384 = Cipher , cipherMinVer = Just TLS12 -- RFC 5289 } --- A list of cipher suite is found from: --- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 +-- See http://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml + +cipherIDtoCipher13 :: CipherID -> Maybe Cipher +cipherIDtoCipher13 0x1301 = Just cipher_TLS13_AES128GCM_SHA256 +cipherIDtoCipher13 0x1302 = Just cipher_TLS13_AES256GCM_SHA384 +cipherIDtoCipher13 _ = Nothing diff --git a/core/Network/TLS/Handshake.hs b/core/Network/TLS/Handshake.hs index fc4524553..931ae0ffa 100644 --- a/core/Network/TLS/Handshake.hs +++ b/core/Network/TLS/Handshake.hs @@ -15,6 +15,7 @@ module Network.TLS.Handshake import Network.TLS.Context.Internal import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.IO import Network.TLS.Util (catchException) @@ -32,6 +33,10 @@ handshake ctx = liftIO $ handleException $ withRWLock ctx (ctxDoHandshake ctx $ ctx) where handleException f = catchException f $ \exception -> do let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception - setEstablished ctx False - sendPacket ctx (errorToAlert tlserror) + setEstablished ctx NotEstablished + tls13 <- tls13orLater ctx + if tls13 then + sendPacket13 ctx $ Alert13 $ errorToAlert tlserror + else + sendPacket ctx $ Alert $ errorToAlert tlserror handshakeFailed tlserror diff --git a/core/Network/TLS/Handshake/Client.hs b/core/Network/TLS/Handshake/Client.hs index 08a2ebaec..9967aa19e 100644 --- a/core/Network/TLS/Handshake/Client.hs +++ b/core/Network/TLS/Handshake/Client.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + -- | -- Module : Network.TLS.Handshake.Client -- License : BSD-style @@ -15,54 +17,101 @@ import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Parameters import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.Cipher import Network.TLS.Compression -import Network.TLS.Packet +import Network.TLS.Packet hiding (getExtensions) +import Network.TLS.Packet13 import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.IO +import Network.TLS.Sending13 import Network.TLS.Imports import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Measurement -import Network.TLS.Wire (encodeWord16) import Network.TLS.Util (bytesEq, catchException) import Network.TLS.Types import Network.TLS.X509 -import Data.Maybe +import Data.Maybe hiding (fromJust) import Data.List (find, intersect) import qualified Data.ByteString as B import Data.ByteString.Char8 () +import Data.Typeable import Control.Monad.State.Strict -import Control.Exception (SomeException) +import Control.Exception (SomeException, Exception) +import qualified Control.Exception as E import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Process import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Key import Network.TLS.Handshake.State +import Network.TLS.Handshake.State13 +import Network.TLS.KeySchedule +import Network.TLS.Extra.Cipher + +import qualified Data.X509 as X +import Network.TLS.Wire handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure) +data HelloSwitch = SwitchTLS13 !CipherID [ExtensionRaw] + | HelloRetry !Version [ExtensionRaw] + deriving (Show, Typeable) + +instance Exception HelloSwitch + -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do + let groups' = supportedGroups (ctxSupported ctx) `intersect` availableGroups + groups = case clientWantSessionResume cparams of + Nothing -> groups' + Just (_, sdata) -> case sessionGroup sdata of + Nothing -> [] -- TLS 1.2 or earlier + Just grp -> [grp] + handshakeClient' cparams ctx groups Nothing + +handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe ClientRandom -> IO () +handshakeClient' cparams ctx groups mcrand = do + putStr $ "groups = " ++ show groups ++ ", keyshare = [" + case groups of + [] -> putStrLn "]" + g:_ -> putStrLn $ show g ++ "]" updateMeasure ctx incrementNbHandshakes - sentExtensions <- sendClientHello - recvServerHello sentExtensions - sessionResuming <- usingState_ ctx isSessionResuming - if sessionResuming - then sendChangeCipherAndFinish ctx ClientRole - else do sendClientData cparams ctx - sendChangeCipherAndFinish ctx ClientRole - recvChangeCipherAndFinish ctx - handshakeTerminate ctx + sentExtensions <- sendClientHello mcrand + ech <- E.try $ recvServerHello sentExtensions + case ech of + Left (SwitchTLS13 cipher exts) -> handshakeClient13 cparams ctx cipher exts + Left (HelloRetry _ver exts) -> case drop 1 groups of + [] -> error "HRR: no common group" -- fixme + groups' -> case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTHelloRetryRequest of + Just (KeyShareHRR selectedGroup) + | selectedGroup `elem` groups' -> do + putStrLn "Retrying client hello..." + usingHState ctx $ setTLS13HRR True + crand <- usingHState ctx $ hstClientRandom <$> get + handshakeClient' cparams ctx [selectedGroup] (Just crand) + _ -> error "HRR: no common group" -- fixme + Right () -> do + putStrLn "TLS 1.2" + sessionResuming <- usingState_ ctx isSessionResuming + if sessionResuming + then sendChangeCipherAndFinish ctx ClientRole + else do sendClientData cparams ctx + sendChangeCipherAndFinish ctx ClientRole + recvChangeCipherAndFinish ctx + handshakeTerminate ctx where ciphers = ctxCiphers ctx compressions = supportedCompressions $ ctxSupported ctx + highestVer = maximum $ supportedVersions $ ctxSupported ctx + tls13 = highestVer >= TLS13ID18 getExtensions = sequence [sniExtension ,secureReneg ,alpnExtension @@ -71,6 +120,11 @@ handshakeClient cparams ctx = do --,sessionTicketExtension ,signatureAlgExtension -- ,heartbeatExtension + ,versionExtension + ,earlyDataExtension + ,keyshareExtension + ,pskExchangeModeExtension + ,preSharedKeyExtension ] toExtensionRaw :: Extension e => e -> ExtensionRaw @@ -101,22 +155,135 @@ handshakeClient cparams ctx = do signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams - sendClientHello = do - crand <- getStateRNG ctx 32 >>= return . ClientRandom - let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams - highestVer = maximum $ supportedVersions $ ctxSupported ctx - extensions <- catMaybes <$> getExtensions + versionExtension + | tls13 = do + let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx + return $ Just $ toExtensionRaw $ SupportedVersions vers + | otherwise = return Nothing + + -- FIXME + keyshareExtension + | tls13 = case groups of + [] -> return Nothing + grp:_ -> do + (cpri, ent) <- makeClientKeyShare ctx grp + usingHState ctx $ setGroupPrivate cpri + return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] + | otherwise = return Nothing + + sessionHash sdata = case cipherIDtoCipher13 (sessionCipher sdata) of + Just cipher -> cipherHash cipher + Nothing -> error "sessionHash" + + preSharedKeyExtension + | not tls13 = return Nothing + | otherwise = case clientWantSessionResume cparams of + Nothing -> return Nothing + Just (sid, sdata) + | sessionVersion sdata >= TLS13ID18 -> do + let usedHash = sessionHash sdata + siz = hashDigestSize usedHash + zero = B.replicate siz 0 + Just tinfo = sessionTicketInfo sdata -- fixme + obfuscatedAge <- getObfuscatedAge tinfo + let identity = PskIdentity sid obfuscatedAge + psk = PreSharedKeyClientHello [identity] [zero] + return $ Just $ toExtensionRaw psk + | otherwise -> return Nothing + + pskExchangeModeExtension + | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE] + | otherwise = return Nothing + + earlyDataExtension = case checkZeroRTT of + Nothing -> return $ Nothing + _ -> return $ Just $ toExtensionRaw EarlyDataIndication + + clientSession = case clientWantSessionResume cparams of + Nothing -> Session Nothing + Just (sid, sdata) + | sessionVersion sdata >= TLS13ID18 -> Session Nothing + | otherwise -> Session (Just sid) + + adjustExtentions exts ch + | not tls13 = return exts + | otherwise = case clientWantSessionResume cparams of + Nothing -> return exts + Just (_, sdata) + | sessionVersion sdata >= TLS13ID18 -> do + let usedHash = sessionHash sdata + siz = hashDigestSize usedHash + zero = B.replicate siz 0 + psk = sessionSecret sdata + earlySecret = hkdfExtract usedHash zero psk + usingHState ctx $ setTLS13MasterSecret (Just earlySecret) + let ech = encodeHandshake ch + binder <- makePSKBinder ctx earlySecret usedHash (siz + 3) (Just ech) + let exts' = init exts ++ [adjust (last exts)] + adjust (ExtensionRaw eid pskz) = (ExtensionRaw eid pskb) + where + pskb = replacePSKBinder pskz binder + return exts' + | otherwise -> return exts + + sendClientHello mcr = do + -- fixme -- "44 4F 57 4E 47 52 44 01" + crand <- case mcr of + Nothing -> getStateRNG ctx 32 >>= return . ClientRandom + Just cr -> return cr startHandshake ctx highestVer crand usingState_ ctx $ setVersionIfUnset highestVer - sendPacket ctx $ Handshake - [ ClientHello highestVer crand clientSession (map cipherID (ciphers mempty)) - (map compressionID compressions) extensions Nothing - ] + let ver = if tls13 then TLS12 else highestVer + cipherIds = map cipherID $ ciphers mempty + compIds = map compressionID compressions + mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing + extensions0 <- catMaybes <$> getExtensions + extensions <- adjustExtentions extensions0 $ mkClientHello extensions0 + sendPacket ctx $ Handshake [mkClientHello extensions] + sendZeroRTT return $ map (\(ExtensionRaw i _) -> i) extensions + checkZeroRTT = case clientWantSessionResume cparams of + Just (_, sdata) + | sessionVersion sdata >= TLS13ID18 -> case clientTLS13ZeroRttData cparams of + Just earlyData -> Just (sessionCipher sdata, earlyData) + Nothing -> Nothing + _ -> Nothing + + sendZeroRTT = case checkZeroRTT of + Nothing -> return () + Just (cid, earlyData) -> do + let usedCipher = case cipherIDtoCipher13 cid of + Just cipher -> cipher + _ -> error "0RTT" -- fixme + usedHash = cipherHash usedCipher + -- fixme: not initialized yet + -- hCh <- getHandshakeContextHash ctx + hmsgs <- usingHState ctx getHandshakeMessages + let hCh = hash usedHash $ B.concat hmsgs + Just earlySecret <- usingHState ctx getTLS13MasterSecret -- fixme + let clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "client early traffic secret" hCh + setTxState ctx usedHash usedCipher clientEarlyTrafficSecret + -- fixme + Right eEarlyData <- writePacket13 ctx $ AppData13 earlyData + Right endOfEarlyData <- writePacket13 ctx $ Alert13 [(AlertLevel_Warning,EndOfEarlyData)] + sendBytes13 ctx (eEarlyData `B.append` endOfEarlyData) + usingHState ctx $ setTLS13RTT0 True + putStrLn "Sending 0RTT request..." + recvServerHello sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p -> case p of + Handshake [hrr@(HelloRetryRequest ver exts)] -> do + let encoded = encodeHandshake hrr + usingHState ctx $ addHandshakeMessage encoded + usingHState ctx $ updateHandshakeDigest encoded + E.throwIO $ HelloRetry ver exts + Handshake [sh@(ServerHello' _ _ c es)] -> do + let encoded = encodeHandshake sh + usingHState ctx $ addHandshakeMessage encoded + usingHState ctx $ updateHandshakeDigest encoded + E.throwIO $ SwitchTLS13 c es Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) hs Alert a -> case a of @@ -307,17 +474,7 @@ onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cip mapM_ processServerExtension exts setVersion rver usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg - - case extensionDecode False `fmap` (extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts) of - Just (Just (ApplicationLayerProtocolNegotiation [proto])) -> usingState_ ctx $ do - mprotos <- getClientALPNSuggest - case mprotos of - Just protos -> when (elem proto protos) $ do - setExtensionALPN True - setNegotiatedProtocol proto - _ -> return () - _ -> return () - + setALPN ctx exts case resumingSession of Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) Just sessionData -> do @@ -399,3 +556,150 @@ processCertificateRequest ctx p = processServerHelloDone ctx p processServerHelloDone :: Context -> Handshake -> IO (RecvState m) processServerHelloDone _ ServerHelloDone = return RecvStateDone processServerHelloDone _ p = unexpected (show p) (Just "server hello data") + +handshakeClient13 :: ClientParams -> Context -> CipherID -> [ExtensionRaw] + -> IO () +handshakeClient13 _cparams ctx cipher exts = do + usedCipher <- case find ((==) cipher . cipherID) (ctxCiphers ctx mempty) of + Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, HandshakeFailure) + Just alg -> return alg + let usedHash = cipherHash usedCipher + putStrLn $ "TLS 1.3: " ++ show usedCipher ++ " " ++ show usedHash + usingHState ctx $ setHelloParameters13 usedCipher + handshakeClient13' _cparams ctx usedCipher usedHash exts + +handshakeClient13' :: ClientParams -> Context -> Cipher -> Hash + -> [ExtensionRaw] -> IO () +handshakeClient13' _cparams ctx usedCipher usedHash exts = do + (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) <- switchToHandshakeSecret + recvEncryptedExtensions + unless resuming recvCertAndVerify + recvFinished serverHandshakeTrafficSecret + hChSf <- getHandshakeContextHash ctx + sendFinished clientHandshakeTrafficSecret + masterSecret <- switchToTrafficSecret handshakeSecret hChSf + setResumptionSecret masterSecret + setEstablished ctx Established + -- not resuming && rtt0 + where + hashSize = hashDigestSize usedHash + zero = B.replicate hashSize 0 + + switchToHandshakeSecret = do + ecdhe <- calcSharedKey + (earlySecret, resuming) <- makeEarlySecret + let handshakeSecret = hkdfExtract usedHash earlySecret ecdhe + hChSh <- getHandshakeContextHash ctx + let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "client handshake traffic secret" hChSh + serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "server handshake traffic secret" hChSh +{- + putStrLn $ "earlySecret: " ++ showBytesHex earlySecret + putStrLn $ "handshakeSecret: " ++ showBytesHex handshakeSecret + putStrLn $ "hChSh: " ++ showBytesHex hChSh + usingHState ctx getHandshakeMessages >>= mapM_ (putStrLn . showBytesHex) + putStrLn $ "serverHandshakeTrafficSecret: " ++ showBytesHex serverHandshakeTrafficSecret + putStrLn $ "clientHandshakeTrafficSecret: " ++ showBytesHex clientHandshakeTrafficSecret +-} + setRxState ctx usedHash usedCipher serverHandshakeTrafficSecret + setTxState ctx usedHash usedCipher clientHandshakeTrafficSecret + return (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) + + switchToTrafficSecret handshakeSecret hChSf = do + let masterSecret = hkdfExtract usedHash handshakeSecret zero + let clientTrafficSecret0 = deriveSecret usedHash masterSecret "client application traffic secret" hChSf + serverTrafficSecret0 = deriveSecret usedHash masterSecret "server application traffic secret" hChSf +{- + putStrLn $ "hChSf: " ++ showBytesHex hChSf + putStrLn $ "masterSecret: " ++ showBytesHex masterSecret + putStrLn $ "serverTrafficSecret0: " ++ showBytesHex serverTrafficSecret0 + putStrLn $ "clientTrafficSecret0: " ++ showBytesHex clientTrafficSecret0 +-} + setTxState ctx usedHash usedCipher clientTrafficSecret0 + setRxState ctx usedHash usedCipher serverTrafficSecret0 + return masterSecret + + update hs = usingHState ctx $ do + let encoded = encodeHandshake13 hs + updateHandshakeDigest encoded + addHandshakeMessage encoded + + calcSharedKey = do + serverKeyShare <- case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTServerHello of + Just (KeyShareServerHello ks) -> return ks + _ -> throwCore $ Error_Protocol ("key exchange not implemented", True, HandshakeFailure) + usingHState ctx $ setTLS13Group $ keyShareEntryGroup serverKeyShare + usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare + + makeEarlySecret = do + mEarlySecret <- usingHState ctx getTLS13MasterSecret + case mEarlySecret of + Nothing -> return (hkdfExtract usedHash zero zero, False) + Just sec -> case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTServerHello of + Nothing -> do + putStrLn "XXX PSK is not accepted by the server ... falling back to full handshake" + return (hkdfExtract usedHash zero zero, False) + Just (PreSharedKeyServerHello 0) -> putStrLn "PSK[0] is used" >> return (sec, True) + Just _ -> throwCore $ Error_Protocol ("psk out of range", True, IllegalParameter) + + recvEncryptedExtensions = do + ee@(EncryptedExtensions13 eexts) <- recvHandshake13 ctx + setALPN ctx eexts + case extensionLookup extensionID_EarlyData eexts of + Just _ -> putStrLn "0RTT is accepted" + Nothing -> return () + update ee + + recvCertAndVerify = do + cert <- recvHandshake13 ctx + update cert + let Certificate13 _ certChain _ = cert + pubkey = X.certPubKey $ X.signedObject $ X.getSigned $ getCertificateChainLeaf certChain -- fixme + certVerify <- recvHandshake13 ctx + let CertVerify13 ss sig = certVerify + hChSc <- getHandshakeContextHash ctx + checkServerCertVerify ss sig pubkey hChSc + update certVerify + + recvFinished serverHandshakeTrafficSecret = do + finished <- recvHandshake13 ctx + hChSv <- getHandshakeContextHash ctx + let verifyData' = makeVerifyData usedHash serverHandshakeTrafficSecret hChSv + let Finished13 verifyData = finished + when (verifyData' /= verifyData) $ + throwCore $ Error_Protocol ("cannot verify finished", True, HandshakeFailure) + update finished + + sendFinished clientHandshakeTrafficSecret = do + fish <- makeFinished ctx usedHash clientHandshakeTrafficSecret >>= writeHandshakePacket13 ctx + sendBytes13 ctx fish + + setResumptionSecret masterSecret = do + hChCf <- getHandshakeContextHash ctx + let resumptionSecret = deriveSecret usedHash masterSecret "resumption master secret" hChCf + usingHState ctx $ setTLS13MasterSecret $ Just resumptionSecret + +recvHandshake13 :: Context -> IO Handshake13 +recvHandshake13 ctx = do + msgs <- usingHState ctx getTLS13HandshakeMsgs + case msgs of + [] -> do + epkt <- recvPacket13 ctx + case epkt of + Right (Handshake13 (h:hs)) -> do + usingHState ctx $ setTLS13HandshakeMsgs hs + return h + x -> error $ show x + h:hs -> do + usingHState ctx $ setTLS13HandshakeMsgs hs + return h + +setALPN :: Context -> [ExtensionRaw] -> IO () +setALPN ctx exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTServerHello of + Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do + mprotos <- getClientALPNSuggest + case mprotos of + Just protos -> when (elem proto protos) $ do + setExtensionALPN True + setNegotiatedProtocol proto + _ -> return () + _ -> return () diff --git a/core/Network/TLS/Handshake/Common.hs b/core/Network/TLS/Handshake/Common.hs index cf18625f0..78179ffb2 100644 --- a/core/Network/TLS/Handshake/Common.hs +++ b/core/Network/TLS/Handshake/Common.hs @@ -14,6 +14,7 @@ module Network.TLS.Handshake.Common , recvPacketHandshake , onRecvStateHandshake , extensionLookup + , getSessionData ) where import Control.Concurrent.MVar @@ -31,6 +32,7 @@ import Network.TLS.Record.State import Network.TLS.Measurement import Network.TLS.Types import Network.TLS.Cipher +import Network.TLS.Crypto.Types (Group) import Network.TLS.Util import Data.List (find) import Data.ByteString.Char8 (ByteString) @@ -41,9 +43,9 @@ import Control.Exception (throwIO) handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err -errorToAlert :: TLSError -> Packet -errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] -errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] +errorToAlert :: TLSError -> [(AlertLevel, AlertDescription)] +errorToAlert (Error_Protocol (_, _, ad)) = [(AlertLevel_Fatal, ad)] +errorToAlert _ = [(AlertLevel_Fatal, InternalError)] unexpected :: String -> Maybe [Char] -> IO a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) @@ -60,7 +62,7 @@ handshakeTerminate ctx = do -- only callback the session established if we have a session case session of Session (Just sessionId) -> do - sessionData <- getSessionData ctx + sessionData <- getSessionData ctx Nothing Nothing liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId (fromJust "session-data" sessionData) _ -> return () -- forget most handshake data and reset bytes counters. @@ -74,7 +76,7 @@ handshakeTerminate ctx = do } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. - setEstablished ctx True + setEstablished ctx Established return () sendChangeCipherAndFinish :: Context @@ -121,8 +123,8 @@ runRecvState _ (RecvStateDone) = return () runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx -getSessionData :: Context -> IO (Maybe SessionData) -getSessionData ctx = do +getSessionData :: Context -> Maybe Group -> Maybe TLS13TicketInfo -> IO (Maybe SessionData) +getSessionData ctx mgroup mlife = do ver <- usingState_ ctx getVersion sni <- usingState_ ctx getClientSNI mms <- usingHState ctx (gets hstMasterSecret) @@ -134,7 +136,9 @@ getSessionData ctx = do , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx , sessionCompression = compressionID $ stCompression tx , sessionClientSNI = sni - , sessionSecret = ms + , sessionSecret = ms + , sessionGroup = mgroup + , sessionTicketInfo = mlife } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString diff --git a/core/Network/TLS/Handshake/Common13.hs b/core/Network/TLS/Handshake/Common13.hs new file mode 100644 index 000000000..9639eea55 --- /dev/null +++ b/core/Network/TLS/Handshake/Common13.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Common13 where + +import Control.Applicative +import Control.Monad +import qualified Crypto.PubKey.RSA.PKCS15 as R +import qualified Crypto.PubKey.RSA.Types as R +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Word +import Network.TLS.Context.Internal +import Network.TLS.Crypto +import qualified Network.TLS.Crypto.IES as IES +import Network.TLS.Extension +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.State +import Network.TLS.Handshake.State13 +import Network.TLS.Handshake.Signature +import Network.TLS.Imports +import Network.TLS.KeySchedule +import Network.TLS.MAC +import Network.TLS.Packet +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Types +import Network.TLS.Wire +import Data.Time + +---------------------------------------------------------------- + +makeFinished :: Context -> Hash -> ByteString -> IO Handshake13 +makeFinished ctx usedHash baseKey = do + transcript <- getHandshakeContextHash ctx + return $ Finished13 $ makeVerifyData usedHash baseKey transcript + +makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString +makeVerifyData usedHash baseKey hashValue = hmac usedHash finishedKey hashValue + where + hashSize = hashDigestSize usedHash + finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize + +---------------------------------------------------------------- + +makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry) +makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of + Left e -> throwCore $ Error_Protocol (show e, True, HandshakeFailure) + Right cpub -> do + (spub, share) <- generateECDHEShared ctx cpub + let wspub = IES.encodeGroupPublic spub + serverKeyShare = KeyShareEntry grp wspub + key = BA.convert share + return (key, serverKeyShare) + where + ecpub = IES.decodeGroupPublic grp wcpub + +makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry) +makeClientKeyShare ctx grp = do + (cpri, cpub) <- generateECDHE ctx grp + let wcpub = IES.encodeGroupPublic cpub + clientKeyShare = KeyShareEntry grp wcpub + return (cpri, clientKeyShare) + +fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString +fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of + Left e -> throwCore $ Error_Protocol (show e, True, HandshakeFailure) + Right spub -> case IES.groupGetShared spub cpri of + Just shared -> return $ BA.convert shared + Nothing -> throwCore $ Error_Protocol ("cannote generate a shared secret on (EC)DH", True, HandshakeFailure) + where + espub = IES.decodeGroupPublic grp wspub + +---------------------------------------------------------------- + +serverContextString :: ByteString +serverContextString = "TLS 1.3, server CertificateVerify" + +clientContextString :: ByteString +clientContextString = "TLS 1.3, client CertificateVerify" + +makeServerCertVerify :: Context -> HashAndSignatureAlgorithm -> PrivKey -> ByteString -> IO Handshake13 +makeServerCertVerify ctx hs privKey hashValue = + CertVerify13 hs <$> sign ctx hs privKey target + where + target = makeTarget serverContextString hashValue + +makeClientCertVerify :: Context -> HashAndSignatureAlgorithm -> PrivKey -> ByteString -> IO Handshake13 +makeClientCertVerify ctx hs privKey hashValue = + CertVerify13 hs <$> sign ctx hs privKey target + where + target = makeTarget clientContextString hashValue + +checkServerCertVerify :: HashAndSignatureAlgorithm -> ByteString -> PubKey -> ByteString -> IO () +checkServerCertVerify hs signature pubKey hashValue = + unless ok $ error "fixme" + where + Just sig = fromPubKey pubKey -- fixme + sigParams = signatureParams sig (Just hs) + target = makeTarget serverContextString hashValue + ok = kxVerify pubKey sigParams target signature + +makeTarget :: ByteString -> ByteString -> ByteString +makeTarget contextString hashValue = runPut $ do + putBytes $ B.pack $ replicate 64 32 + putBytes contextString + putWord8 0 + putBytes hashValue + +sign :: Context -> HashAndSignatureAlgorithm -> PrivKey -> ByteString -> IO ByteString +sign ctx hs privKey target = usingState_ ctx $ do + r <- withRNG $ kxSign privKey sigParams target + case r of + Left err -> fail ("sign failed: " ++ show err) + Right econtent -> return econtent + where + Just sig = fromPrivKey privKey -- fixme + sigParams = signatureParams sig (Just hs) + +---------------------------------------------------------------- + +encryptSessionData :: PubKey -> SessionData -> IO (Either R.Error SessionLabel) +encryptSessionData (PubKeyRSA rsaPub) sdata = R.encrypt rsaPub $ encodeSessionData sdata +encryptSessionData _ _ = error "encryptSessionData" + +decryptSessionData :: PrivKey -> SessionLabel -> IO (Either R.Error SessionData) +decryptSessionData (PrivKeyRSA rsaPriv) ticket = do + ebs <- R.decryptSafer rsaPriv ticket + case ebs of + Right bs -> case decodeSessionData bs of + Just sdata -> return $ Right sdata + Nothing -> return $ Left R.MessageNotRecognized -- fixme + Left e -> return $ Left e +decryptSessionData _ _ = error "decryptSessionData" + +encodeSessionData :: SessionData -> ByteString +encodeSessionData (SessionData ver cid comp msni rsecret mgroup mlife) = runPut $ do + putVersion' ver + putWord16 cid + putWord8 comp + case msni of + Just sni -> putOpaque8 $ BC.pack sni + Nothing -> putOpaque8 "" + case mgroup of + Nothing -> putWord16 0 + Just group -> putWord16 $ fromEnumSafe16 group + case mlife of + Just (TLS13TicketInfo life add tm) -> do + putWord32 life + putWord32 add + putWord64 tm + Nothing -> putBytes $ B.replicate 16 0 + putBytes rsecret + +decodeSessionData :: ByteString -> Maybe SessionData +decodeSessionData = runGetMaybe $ do + Just ver <- getVersion' -- fixme + cid <- getWord16 + comp <- getWord8 + sni <- getOpaque8 + let msni + | sni == "" = Nothing + | otherwise = Just $ BC.unpack sni + grp <- getWord16 + let mgrp = toEnumSafe16 grp + life <- getWord32 + add <- getWord32 + tm <- getWord64 + let mlife = Just $ TLS13TicketInfo life add tm + rsecret <- remaining >>= getBytes + return $ SessionData ver cid comp msni rsecret mgrp mlife + +---------------------------------------------------------------- + +makePSKBinder :: Context -> ByteString -> Hash -> Int -> Maybe ByteString -> IO ByteString +makePSKBinder ctx earlySecret usedHash truncLen mch = do + rmsgs0 <- usingHState ctx getHandshakeMessagesRev + let rmsgs = case mch of + Just ch -> trunc ch : rmsgs0 + Nothing -> trunc (head rmsgs0) : tail rmsgs0 + hChTruncated = hash usedHash $ B.concat $ reverse rmsgs + binderKey = deriveSecret usedHash earlySecret "resumption psk binder key" (hash usedHash "") + return $ makeVerifyData usedHash binderKey hChTruncated + where + trunc x = B.take takeLen x + where + totalLen = B.length x + takeLen = totalLen - truncLen + +replacePSKBinder :: ByteString -> ByteString -> ByteString +replacePSKBinder pskz binder = identities `B.append` binders + where + bindersSize = B.length binder + 3 + identities = B.take (B.length pskz - bindersSize) pskz + binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder + +---------------------------------------------------------------- + +createTLS13TicketInfo :: Word32 -> Either Context Word32 -> IO TLS13TicketInfo +createTLS13TicketInfo life ecw = do + -- Left: serverSendTime + -- Right: clientReceiveTime + bTime <- millisecondsFromBase <$> getCurrentTime + add <- case ecw of + Left ctx -> B.foldl' (*+) 0 <$> usingState_ ctx (genRandom 4) + Right ad -> return ad + return $ TLS13TicketInfo life add bTime + where + x *+ y = x * 256 + fromIntegral y + +getObfuscatedAge :: TLS13TicketInfo -> IO Word32 +getObfuscatedAge (TLS13TicketInfo _ add clientReceiveTime) = do + clientSendTime <- millisecondsFromBase <$> getCurrentTime + let age = fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds + return (age + add) + +revealObfuscatedAge :: Word32 -> TLS13TicketInfo -> Word32 +revealObfuscatedAge obfage (TLS13TicketInfo _ add _) = obfage - add + +getTripTime :: TLS13TicketInfo -> IO Word32 +getTripTime (TLS13TicketInfo _ _ serverSendTime) = do + serverReceiveTime <- millisecondsFromBase <$> getCurrentTime + return $ fromIntegral (serverReceiveTime - serverSendTime) + +millisecondsFromBase :: UTCTime -> Word64 +millisecondsFromBase d = fromInteger ms + where + ps = diffTimeToPicoseconds $ realToFrac $ diffUTCTime d base + ms = ps `div` 1000000000 + base = UTCTime (fromGregorian 2017 1 1) 0 diff --git a/core/Network/TLS/Handshake/Process.hs b/core/Network/TLS/Handshake/Process.hs index a929155a7..8cefd726e 100644 --- a/core/Network/TLS/Handshake/Process.hs +++ b/core/Network/TLS/Handshake/Process.hs @@ -103,7 +103,7 @@ processClientKeyXchg ctx (CKX_ECDH bytes) = do case decodeGroupPublic grp bytes of Left _ -> throwCore $ Error_Protocol ("client public key cannot be decoded", True, HandshakeFailure) Right clipub -> do - srvpri <- usingHState ctx getECDHPrivate + srvpri <- usingHState ctx getGroupPrivate case groupGetShared clipub srvpri of Just premaster -> do rver <- usingState_ ctx getVersion @@ -120,8 +120,16 @@ processClientFinished ctx fdata = do usingState_ ctx $ updateVerifiedData ServerRole fdata return () --- initialize a new Handshake context (initial handshake or renegotiations) +-- initialize a new Handshake context startHandshake :: Context -> Version -> ClientRandom -> IO () -startHandshake ctx ver crand = - let hs = Just $ newEmptyHandshake ver crand - in liftIO $ void $ swapMVar (ctxHandshake ctx) hs +startHandshake ctx ver crand = do + mhst <- getHState ctx + let mhst' = case mhst of + -- Flesh negotiation + Nothing -> Just $ newEmptyHandshake ver crand + Just oldhst + -- TLS 1.3 hello retry: Handshake messages etc must be preserved. + | hstTLS13HRR oldhst -> Just oldhst + -- TLS 1.2 renegotiation: state must be initialized again. + | otherwise -> Just $ newEmptyHandshake ver crand + liftIO $ modifyMVar_ (ctxHandshake ctx) $ \_ -> return mhst' diff --git a/core/Network/TLS/Handshake/Server.hs b/core/Network/TLS/Handshake/Server.hs index 1470449e0..66b2fe59c 100644 --- a/core/Network/TLS/Handshake/Server.hs +++ b/core/Network/TLS/Handshake/Server.hs @@ -17,6 +17,8 @@ import Network.TLS.Imports import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Packet13 import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials @@ -24,6 +26,7 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Util (catchException, fromJust) import Network.TLS.IO +import Network.TLS.Sending13 import Network.TLS.Types import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Handshake.State @@ -31,7 +34,7 @@ import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key import Network.TLS.Measurement import Data.Maybe (isJust, listToMaybe, mapMaybe) -import Data.List (intersect, any) +import Data.List (intersect, any, find) import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.Ord (Down(..)) @@ -49,6 +52,12 @@ import Network.TLS.Handshake.Common import Network.TLS.Handshake.Certificate import Network.TLS.X509 +import Network.TLS.Handshake.State13 +import Network.TLS.KeySchedule +import Network.TLS.Handshake.Common13 + +import qualified Data.X509 as X + -- Put the server context in handshake mode. -- -- Expect to receive as first packet a client hello handshake message @@ -88,11 +97,12 @@ handshakeServer sparams ctx = liftIO $ do -- handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientSession ciphers compressions exts _) = do + putStrLn "---- handshake ----" -- rejecting client initiated renegotiation to prevent DOS. unless (supportedClientInitiatedRenegotiation (ctxSupported ctx)) $ do established <- ctxEstablished ctx eof <- ctxEOF ctx - when (established && not eof) $ + when (established == Established && not eof) $ throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation) -- check if policy allow this new handshake to happens handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) @@ -113,7 +123,18 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS (0x5600 `elem` ciphers) && clientVersion /= maxBound) $ throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback) - chosenVersion <- case findHighestVersionFrom clientVersion (supportedVersions $ ctxSupported ctx) of + + -- choosing TLS version + let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of + Just (SupportedVersions vers) -> vers + _ -> [] + serverVersions = supportedVersions $ ctxSupported ctx + mver + | (TLS13ID18 `elem` serverVersions) && clientVersion == TLS12 && clientVersions /= [] = + findHighestVersionFrom13 clientVersions serverVersions + | otherwise = findHighestVersionFrom clientVersion serverVersions + + chosenVersion <- case mver of Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion) Just v -> return v @@ -122,12 +143,19 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS Error_Protocol ("no compression in common with the client", True, HandshakeFailure) -- SNI (Server Name Indication) - let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode False of + let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode MsgTClientHello of Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) where toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing _ -> Nothing + maybe (return ()) (usingState_ ctx . setClientSNI) serverName + -- ALPN (Application Layer Protocol Negotiation) + case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of + Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos + _ -> return () + + -- choosing cipher suite extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName -- When selecting a cipher we must ensure that it is allowed for the @@ -148,6 +176,9 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE _ -> True -- group not used let cipherAllowed cipher = case chosenVersion of + TLS13ID18 -> case cipherMinVer cipher of + Nothing -> False + Just cVer -> cVer == chosenVersion TLS12 -> let -- Build a list of all signature algorithms with at least -- one hash algorithm in common between client and server. -- May contain duplicates, as it is only used for `elem`. @@ -177,7 +208,36 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS let usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion creds = extraCreds `mappend` sharedCredentials (ctxShared ctx) + print chosenVersion + print usedCipher + -- TLS version dependent + if chosenVersion <= TLS12 then + handshakeServerWithTLS12 sparams creds ctx chosenVersion usedCipher usedCompression clientSession exts serverName clientVersion ciphers compressions + else + handshakeServerWithTLS13 sparams creds ctx chosenVersion usedCipher exts + where + commonCipherIDs extra = ciphers `intersect` map cipherID (ctxCiphers ctx extra) + commonCiphers extra = filter (flip elem (commonCipherIDs extra) . cipherID) (ctxCiphers ctx extra) + commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions + usedCompression = head commonCompressions + +handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) +-- TLS 1.2 or earlier +handshakeServerWithTLS12 :: ServerParams + -> Credentials + -> Context + -> Version + -> Cipher + -> Compression + -> Session + -> [ExtensionRaw] + -> Maybe String + -> Version + -> [CipherID] + -> [CompressionID] + -> IO () +handshakeServerWithTLS12 sparams creds ctx chosenVersion usedCipher usedCompression clientSession exts serverName clientVersion ciphers compressions = do cred <- case cipherKeyExchange usedCipher of CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds CipherKeyExchange_DH_Anon -> return $ Nothing @@ -192,26 +252,14 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS in validateSession serverName <$> resume (Session Nothing) -> return Nothing - maybe (return ()) (usingState_ ctx . setClientSNI) serverName - - case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode False of - Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos - _ -> return () - -- Currently, we don't send back EcPointFormats. In this case, -- the client chooses EcPointFormat_Uncompressed. - case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode False of + case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode MsgTClientHello of Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs _ -> return () doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts - where - commonCipherIDs extra = ciphers `intersect` map cipherID (ctxCiphers ctx extra) - commonCiphers extra = filter (flip elem (commonCipherIDs extra) . cipherID) (ctxCiphers ctx extra) - commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions - usedCompression = head commonCompressions - validateSession _ Nothing = Nothing validateSession sni m@(Just sd) -- SessionData parameters are assumed to match the local server configuration @@ -224,9 +272,6 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS | isJust sni && sessionClientSNI sd /= sni = Nothing | otherwise = m - -handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure) - doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher -> Compression -> Session -> Maybe SessionData -> [ExtensionRaw] -> IO () @@ -247,21 +292,6 @@ doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSes recvChangeCipherAndFinish ctx handshakeTerminate ctx where - clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts - - applicationProtocol | clientALPNSuggest = do - suggest <- usingState_ ctx getClientALPNSuggest - case (onALPNClientSuggest $ serverHooks sparams, suggest) of - (Just io, Just protos) -> do - proto <- liftIO $ io protos - usingState_ ctx $ do - setExtensionALPN True - setNegotiatedProtocol proto - return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation - (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] - (_, _) -> return [] - | otherwise = return [] - --- -- When the client sends a certificate, check whether -- it is acceptable for the application. @@ -284,7 +314,8 @@ doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSes return $ extensionEncode (SecureRenegotiation cvf $ Just svf) return [ ExtensionRaw extensionID_SecureRenegotiation vf ] else return [] - protoExt <- applicationProtocol + + protoExt <- applicationProtocol ctx exts sparams sniExt <- do resuming <- usingState_ ctx isSessionResuming if resuming @@ -387,7 +418,7 @@ doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSes (srvpri, srvpub) <- generateECDHE ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams - usingHState ctx $ setECDHPrivate srvpri + usingHState ctx $ setGroupPrivate srvpri return serverParams generateSKX_ECDHE sigAlg = do @@ -497,11 +528,9 @@ recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientC getRemoteSignatureAlg = do pk <- usingHState ctx getRemotePublicKey - case pk of - PubKeyRSA _ -> return RSA - PubKeyDSA _ -> return DSS - PubKeyEC _ -> return ECDSA - _ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) + case fromPubKey pk of + Nothing -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) + Just sig -> return sig expectChangeCipher ChangeCipherSpec = do return $ RecvStateHandshake $ expectFinish @@ -519,9 +548,10 @@ recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientC Just cc | isNullCertificateChain cc -> throwCore throwerror | otherwise -> return () + hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] hashAndSignaturesInCommon ctx exts = - let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of + let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of -- See Section 7.4.1.4.1 of RFC 5246. Nothing -> [(HashSHA1, SignatureECDSA) ,(HashSHA1, SignatureRSA) @@ -534,21 +564,282 @@ hashAndSignaturesInCommon ctx exts = -- to server preference in 'supportedHashSignatures'. in sHashSigs `intersect` cHashSigs + negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] -negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode False of +negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of Just (NegotiatedGroups clientGroups) -> let serverGroups = supportedGroups (ctxSupported ctx) `intersect` availableGroups in serverGroups `intersect` clientGroups _ -> [] +-- TLS 1.3 or later +handshakeServerWithTLS13 :: ServerParams + -> Credentials + -> Context + -> Version + -> Cipher + -> [ExtensionRaw] + -> IO () +handshakeServerWithTLS13 sparams creds ctx chosenVersion usedCipher exts = do + -- TLS 1.3 or later + -- Deciding key exchange from key shares + keyShares <- case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTClientHello of + Just (KeyShareClientHello kses) -> return kses + _ -> throwCore $ Error_Protocol ("key exchange not implemented", True, HandshakeFailure) + putStrLn $ "keyshare = " ++ show (map keyShareEntryGroup keyShares) +{- + putStrLn "Handshake messages:" + usingHState ctx getHandshakeMessages >>= mapM_ (putStrLn . showBytesHex) +-} + let serverGroups = supportedGroups (ctxSupported ctx) `intersect` availableGroups + case findKeyShare keyShares serverGroups of + Nothing -> helloRetryRequest sparams ctx chosenVersion exts serverGroups + Just keyShare -> do + print $ keyShareEntryGroup keyShare + -- Deciding signature algorithm + let hashSigs = hashAndSignaturesInCommon ctx exts + Just (cred, sigAlgo) = credentialsFindForSigning13 hashSigs creds -- fixme + let usedHash = cipherHash usedCipher + doHandshake13 sparams cred ctx chosenVersion usedCipher exts usedHash keyShare sigAlgo + where + findKeyShare _ [] = Nothing + findKeyShare ks (g:gs) = case find (\ent -> keyShareEntryGroup ent == g) ks of + Just k -> Just k + Nothing -> findKeyShare ks gs + +doHandshake13 :: ServerParams -> Credential -> Context -> Version + -> Cipher -> [ExtensionRaw] + -> Hash -> KeyShareEntry -> HashAndSignatureAlgorithm + -> IO () +doHandshake13 sparams (certChain, privKey) ctx chosenVersion usedCipher exts usedHash clientKeyShare sigAlgo = do + print chosenVersion + print usedCipher + print sigAlgo + when (isNullCertificateChain certChain) $ + throwCore $ Error_Protocol ("no certification found", True, HandshakeFailure) + newSession ctx >>= \ss -> usingState_ ctx (setSession ss False) + usingHState ctx $ setTLS13Group $ keyShareEntryGroup clientKeyShare + srand <- setServerParameter + (psk, binderInfo) <- choosePSK + hCh <- getHandshakeContextHash ctx + let earlySecret = hkdfExtract usedHash zero psk + clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "client early traffic secret" hCh + extensions <- checkBinder earlySecret binderInfo + let authenticated = isJust binderInfo + ---------------------------------------------------------------- + putStrLn $ if authenticated then + if rtt0 then "<<<0RTT>>>" else "<<>>" + else + "<<>>" + (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare + let handshakeSecret = hkdfExtract usedHash earlySecret ecdhe + helo <- makeServerHello keyShare srand extensions >>= writeHandshakePacket13 ctx + ---------------------------------------------------------------- + hChSh <- getHandshakeContextHash ctx + let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "client handshake traffic secret" hChSh + serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "server handshake traffic secret" hChSh + setRxState ctx usedHash usedCipher $ if rtt0 then clientEarlyTrafficSecret else clientHandshakeTrafficSecret + setTxState ctx usedHash usedCipher serverHandshakeTrafficSecret + ---------------------------------------------------------------- + serverHandshake <- makeServerHandshake authenticated serverHandshakeTrafficSecret + sendBytes13 ctx $ B.concat (helo : serverHandshake) + ---------------------------------------------------------------- + let masterSecret = hkdfExtract usedHash handshakeSecret zero + hChSf <- getHandshakeContextHash ctx + let clientTrafficSecret0 = deriveSecret usedHash masterSecret "client application traffic secret" hChSf + serverTrafficSecret0 = deriveSecret usedHash masterSecret "server application traffic secret" hChSf + verifyData = makeVerifyData usedHash clientHandshakeTrafficSecret hChSf + clientFinished = encodeHandshake13 $ Finished13 verifyData + ---------------------------------------------------------------- + setTxState ctx usedHash usedCipher serverTrafficSecret0 + sendNewSessionTicket masterSecret clientFinished + ---------------------------------------------------------------- + let established = if authenticated && rtt0 then EarlyDataAllowed + else EarlyDataNotAllowed + setEstablished ctx established + let finishedAction verifyData' + | verifyData == verifyData' = do + setEstablished ctx Established + setRxState ctx usedHash usedCipher clientTrafficSecret0 + | otherwise = throwCore $ Error_Protocol ("cannot verify finished", True, HandshakeFailure) + if rtt0 then do + let alertAction = \_ -> do + setRxState ctx usedHash usedCipher clientHandshakeTrafficSecret + setPendingActions ctx [alertAction, finishedAction] + else do + setPendingActions ctx [finishedAction] + where + setServerParameter = do + srand <- ServerRandom <$> getStateRNG ctx 32 + usingHState ctx $ setPrivateKey privKey + usingState_ ctx $ setVersion chosenVersion + usingHState ctx $ setHelloParameters13 usedCipher + return srand + + choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of + Just (PreSharedKeyClientHello (PskIdentity ticket obfAge:_) bnds@(bnd:_)) -> do + let len = sum (map (\x -> B.length x + 1) bnds) + 2 + esdata <- decryptSessionData privKey ticket + case esdata of + Right sdata -> do + let Just tinfo = sessionTicketInfo sdata + age = revealObfuscatedAge obfAge tinfo + tripTime <- getTripTime tinfo + if age <= lifetime tinfo * 1000 && + -- fixme: 2000 milliseconds for RTT + delta + tripTime - age < 2000 then do + let psk = sessionSecret sdata + return (psk, Just (bnd,0::Int,len)) + else + throwCore $ Error_Protocol ("PSK validation failed", True, HandshakeFailure) + Left _ -> return (zero, Nothing) + _ -> return (zero, Nothing) + + rtt0 = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTClientHello of + Just EarlyDataIndication -> True + Nothing -> False + + checkBinder _ Nothing = return [] + checkBinder earlySecret (Just (binder,n,tlen)) = do + binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing + when (binder /= binder') $ + throwCore $ Error_Protocol ("PSK binder validation failed", True, HandshakeFailure) + let spsk = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n + return [ExtensionRaw extensionID_PreSharedKey spsk] + + makeServerHello keyShare srand extensions = do + let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare + extensions' = ExtensionRaw extensionID_KeyShare serverKeyShare + : extensions + return $ ServerHello13 chosenVersion srand (cipherID usedCipher) extensions' + + makeServerHandshake False serverHandshakeTrafficSecret = do + eext <- makeExtensions >>= writeHandshakePacket13 ctx + let CertificateChain cs = certChain + ess = replicate (length cs) [] + cert <- writeHandshakePacket13 ctx $ Certificate13 "" certChain ess + hChSc <- getHandshakeContextHash ctx + vrfy <- makeServerCertVerify ctx sigAlgo privKey hChSc >>= writeHandshakePacket13 ctx + fish <- makeFinished ctx usedHash serverHandshakeTrafficSecret >>= writeHandshakePacket13 ctx + return $ [eext, cert, vrfy, fish] + makeServerHandshake True serverHandshakeTrafficSecret = do + eext <- makeExtensions >>= writeHandshakePacket13 ctx + fish <- makeFinished ctx usedHash serverHandshakeTrafficSecret >>= writeHandshakePacket13 ctx + return $ [eext, fish] + + makeExtensions = do + extensions' <- applicationProtocol ctx exts sparams + msni <- usingState_ ctx getClientSNI + let extensions'' = case msni of + -- RFC6066: In this event, the server SHALL include + -- an extension of type "server_name" in the + -- (extended) server hello. The "extension_data" + -- field of this extension SHALL be empty. + Just _ -> ExtensionRaw extensionID_ServerName "" : extensions' + Nothing -> extensions' + let extensions + | rtt0 = ExtensionRaw extensionID_EarlyData (extensionEncode EarlyDataIndication) : extensions'' + | otherwise = extensions'' + return $ EncryptedExtensions13 extensions + + sendNewSessionTicket masterSecret clientFinished = when sendNST $ do + usingHState ctx $ do + updateHandshakeDigest clientFinished + addHandshakeMessage clientFinished + hChCf <- getHandshakeContextHash ctx + let resumptionSecret = deriveSecret usedHash masterSecret "resumption master secret" hChCf + life = 604800 -- seconds (seven days): fixme hard coding + (ticket, add) <- createEncryptedTicket life resumptionSecret + let nst = createNewSessionTicket life add ticket + sendPacket13 ctx $ Handshake13 [nst] + where + sendNST = (PSK_KE `elem` dhModes) || (PSK_DHE_KE `elem` dhModes) + dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of + Just (PskKeyExchangeModes ms) -> ms + Nothing -> [] + createEncryptedTicket life resumptionSecret = do + serverName <- usingState_ ctx getClientSNI + tinfo <- createTLS13TicketInfo life (Left ctx) + let sdata = SessionData chosenVersion (cipherID usedCipher) 0 serverName resumptionSecret (Just grp) (Just tinfo) + Right ticket <- encryptSessionData pubKey sdata -- fixme + return (ticket, ageAdd tinfo) + where + grp = keyShareEntryGroup clientKeyShare + pubKey = X.certPubKey $ X.signedObject $ X.getSigned $ getCertificateChainLeaf certChain + createNewSessionTicket life add ticket = NewSessionTicket13 life add ticket extensions + where + tedi = extensionEncode $ TicketEarlyDataInfo 2048 -- 2 KiB: fixme hard coding + extensions = [ExtensionRaw extensionID_TicketEarlyDataInfo tedi] + + hashSize = hashDigestSize usedHash + zero = B.replicate hashSize 0 + +helloRetryRequest :: MonadIO m => ServerParams -> Context -> Version -> [ExtensionRaw] -> [Group] -> m () +helloRetryRequest sparams ctx chosenVersion exts serverGroups = liftIO $ do + twice <- usingHState ctx getTLS13HRR + when twice $ + throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure) + usingHState ctx $ setTLS13HRR True + let clientGroups = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of + Just (NegotiatedGroups gs) -> gs + Nothing -> [] + possibleGroups = serverGroups `intersect` clientGroups + case possibleGroups of + [] -> throwCore $ Error_Protocol ("key exchange not implemented", True, HandshakeFailure) + g:_ -> do + let ext = ExtensionRaw extensionID_KeyShare $ extensionEncode $ KeyShareHRR g + hrr = HelloRetryRequest13 chosenVersion [ext] + putStrLn $ "Sending hello retry request for " ++ show g + sendPacket13 ctx $ Handshake13 [hrr] + handshakeServer sparams ctx + findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of [] -> Nothing v:_ -> Just v +findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version +findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of + [] -> Nothing + v:_ -> Just v + where + svs = sortOn Down serverVersions + cvs = sortOn Down clientVersions + +applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] +applicationProtocol ctx exts sparams + | clientALPNSuggest = do + suggest <- usingState_ ctx getClientALPNSuggest + case (onALPNClientSuggest $ serverHooks sparams, suggest) of + (Just io, Just protos) -> do + proto <- liftIO $ io protos + usingState_ ctx $ do + setExtensionALPN True + setNegotiatedProtocol proto + return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation + (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] + (_, _) -> return [] + | otherwise = return [] + where + clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts + #if !MIN_VERSION_base(4,8,0) sortOn :: Ord b => (a -> b) -> [a] -> [a] sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) #endif + +credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm) +credentialsFindForSigning13 hss0 creds = loop hss0 + where + loop [] = Nothing + loop (hs:hss) = case credentialsFindForSigning13' hs creds of + Nothing -> credentialsFindForSigning13 hss creds + Just cred -> Just (cred, hs) + +credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential +credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l + where forSigning cred = case credentialCanSign cred of + Nothing -> False + Just sig -> sig `signatureCompatible` sigAlg diff --git a/core/Network/TLS/Handshake/Signature.hs b/core/Network/TLS/Handshake/Signature.hs index 777f8e73e..770ea165f 100644 --- a/core/Network/TLS/Handshake/Signature.hs +++ b/core/Network/TLS/Handshake/Signature.hs @@ -15,6 +15,9 @@ module Network.TLS.Handshake.Signature , digitallySignDHParamsVerify , digitallySignECDHParamsVerify , signatureCompatible + , signatureParams + , fromPubKey + , fromPrivKey ) where import Network.TLS.Crypto @@ -30,6 +33,16 @@ import Network.TLS.Util import Control.Monad.State.Strict +fromPubKey :: PubKey -> Maybe DigitalSignatureAlg +fromPubKey (PubKeyRSA _) = Just RSA +fromPubKey (PubKeyDSA _) = Just DSS +fromPubKey (PubKeyEC _) = Just ECDSA +fromPubKey _ = Nothing + +fromPrivKey :: PrivKey -> Maybe DigitalSignatureAlg +fromPrivKey (PrivKeyRSA _) = Just RSA +fromPrivKey (PrivKeyDSA _) = Just DSS + signatureCompatible :: DigitalSignatureAlg -> HashAndSignatureAlgorithm -> Bool signatureCompatible RSA (_, SignatureRSA) = True signatureCompatible RSA (_, SignatureRSApssSHA256) = True diff --git a/core/Network/TLS/Handshake/State.hs b/core/Network/TLS/Handshake/State.hs index dac549625..686f41c11 100644 --- a/core/Network/TLS/Handshake/State.hs +++ b/core/Network/TLS/Handshake/State.hs @@ -25,8 +25,8 @@ module Network.TLS.Handshake.State , getServerECDHParams , setDHPrivate , getDHPrivate - , setECDHPrivate - , getECDHPrivate + , setGroupPrivate + , getGroupPrivate -- * cert accessors , setClientCertSent , getClientCertSent @@ -40,17 +40,29 @@ module Network.TLS.Handshake.State , addHandshakeMessage , updateHandshakeDigest , getHandshakeMessages + , getHandshakeMessagesRev , getHandshakeDigest -- * master secret + , setTLS13MasterSecret + , getTLS13MasterSecret , setMasterSecret , setMasterSecretFromPre -- * misc accessor , getPendingCipher , setServerHelloParameters + , setTLS13Group + , getTLS13Group + , setTLS13HRR + , getTLS13HRR + , setTLS13RTT0 + , getTLS13RTT0 + , setTLS13HandshakeMsgs + , getTLS13HandshakeMsgs ) where import Network.TLS.Util import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.Record.State import Network.TLS.Packet import Network.TLS.Crypto @@ -77,7 +89,7 @@ data HandshakeState = HandshakeState , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate) , hstServerECDHParams :: !(Maybe ServerECDHParams) - , hstECDHPrivate :: !(Maybe GroupPrivate) + , hstGroupPrivate :: !(Maybe GroupPrivate) , hstHandshakeDigest :: !(Either [ByteString] HashCtx) , hstHandshakeMessages :: [ByteString] , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received @@ -88,6 +100,10 @@ data HandshakeState = HandshakeState , hstPendingRxState :: Maybe RecordState , hstPendingCipher :: Maybe Cipher , hstPendingCompression :: Compression + , hstTLS13Group :: Maybe Group + , hstTLS13HRR :: !Bool + , hstTLS13RTT0 :: !Bool + , hstTLS13HandshakeMsgs :: [Handshake13] } deriving (Show) type ClientCertRequestData = ([CertificateType], @@ -115,7 +131,7 @@ newEmptyHandshake ver crand = HandshakeState , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing - , hstECDHPrivate = Nothing + , hstGroupPrivate = Nothing , hstHandshakeDigest = Left [] , hstHandshakeMessages = [] , hstClientCertRequest = Nothing @@ -126,6 +142,10 @@ newEmptyHandshake ver crand = HandshakeState , hstPendingRxState = Nothing , hstPendingCipher = Nothing , hstPendingCompression = nullCompression + , hstTLS13Group = Nothing + , hstTLS13HRR = False + , hstTLS13RTT0 = False + , hstTLS13HandshakeMsgs = [] } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState) @@ -145,29 +165,59 @@ getRemotePublicKey = fromJust "remote public key" <$> gets (hksRemotePublicKey . getLocalPrivateKey :: HandshakeM PrivKey getLocalPrivateKey = fromJust "local private key" <$> gets (hksLocalPrivateKey . hstKeyState) +setServerDHParams :: ServerDHParams -> HandshakeM () +setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp }) + getServerDHParams :: HandshakeM ServerDHParams getServerDHParams = fromJust "server DH params" <$> gets hstServerDHParams +setServerECDHParams :: ServerECDHParams -> HandshakeM () +setServerECDHParams shp = modify (\hst -> hst { hstServerECDHParams = Just shp }) + getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust "server ECDH params" <$> gets hstServerECDHParams -setServerDHParams :: ServerDHParams -> HandshakeM () -setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp }) - -setServerECDHParams :: ServerECDHParams -> HandshakeM () -setServerECDHParams shp = modify (\hst -> hst { hstServerECDHParams = Just shp }) +setDHPrivate :: DHPrivate -> HandshakeM () +setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp }) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust "server DH private" <$> gets hstDHPrivate -getECDHPrivate :: HandshakeM GroupPrivate -getECDHPrivate = fromJust "server ECDH private" <$> gets hstECDHPrivate +getGroupPrivate :: HandshakeM GroupPrivate +getGroupPrivate = fromJust "server ECDH private" <$> gets hstGroupPrivate -setDHPrivate :: DHPrivate -> HandshakeM () -setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp }) +setGroupPrivate :: GroupPrivate -> HandshakeM () +setGroupPrivate shp = modify (\hst -> hst { hstGroupPrivate = Just shp }) + +setTLS13Group :: Group -> HandshakeM () +setTLS13Group g = modify (\hst -> hst { hstTLS13Group = Just g }) + +getTLS13Group :: HandshakeM (Maybe Group) +getTLS13Group = gets hstTLS13Group + +setTLS13HRR :: Bool -> HandshakeM () +setTLS13HRR b = modify (\hst -> hst { hstTLS13HRR = b }) + +getTLS13HRR :: HandshakeM Bool +getTLS13HRR = gets hstTLS13HRR -setECDHPrivate :: GroupPrivate -> HandshakeM () -setECDHPrivate shp = modify (\hst -> hst { hstECDHPrivate = Just shp }) +setTLS13RTT0 :: Bool -> HandshakeM () +setTLS13RTT0 b = modify (\hst -> hst { hstTLS13RTT0 = b }) + +getTLS13RTT0 :: HandshakeM Bool +getTLS13RTT0 = gets hstTLS13RTT0 + +setTLS13HandshakeMsgs :: [Handshake13] -> HandshakeM () +setTLS13HandshakeMsgs hmsgs = modify (\hst -> hst { hstTLS13HandshakeMsgs = hmsgs }) + +getTLS13HandshakeMsgs :: HandshakeM [Handshake13] +getTLS13HandshakeMsgs = gets hstTLS13HandshakeMsgs + +setTLS13MasterSecret :: Maybe ByteString -> HandshakeM () +setTLS13MasterSecret msecret = modify (\hst -> hst { hstMasterSecret = msecret }) + +getTLS13MasterSecret :: HandshakeM (Maybe ByteString) +getTLS13MasterSecret = gets hstMasterSecret setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b }) @@ -202,6 +252,9 @@ addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = conten getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) +getHandshakeMessagesRev :: HandshakeM [ByteString] +getHandshakeMessagesRev = gets hstHandshakeMessages + updateHandshakeDigest :: ByteString -> HandshakeM () updateHandshakeDigest content = modify $ \hs -> hs { hstHandshakeDigest = case hstHandshakeDigest hs of diff --git a/core/Network/TLS/Handshake/State13.hs b/core/Network/TLS/Handshake/State13.hs new file mode 100644 index 000000000..f02e3da6e --- /dev/null +++ b/core/Network/TLS/Handshake/State13.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.TLS.Handshake.State +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Handshake.State13 where + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad.State +import Data.ByteString (ByteString) +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Context.Internal +import Network.TLS.Crypto +import Network.TLS.Handshake.State +import Network.TLS.KeySchedule (hkdfExpandLabel) +import Network.TLS.Record.State + +setTxState :: Context -> Hash -> Cipher -> ByteString -> IO () +setTxState = setXState ctxTxState BulkEncrypt + +setRxState :: Context -> Hash -> Cipher -> ByteString -> IO () +setRxState = setXState ctxRxState BulkDecrypt + +setXState :: (Context -> MVar RecordState) -> BulkDirection + -> Context -> Hash -> Cipher -> ByteString + -> IO () +setXState func encOrDec ctx h cipher secret = + modifyMVar_ (func ctx) (\_ -> return rt) + where + bulk = cipherBulk cipher + keySize = bulkKeySize bulk + ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk) + key = hkdfExpandLabel h secret "key" "" keySize + iv = hkdfExpandLabel h secret "iv" "" ivSize + cst = CryptState { + cstKey = bulkInit bulk encOrDec key + , cstIV = iv + , cstMacSecret = "" -- not used in TLS 1.3 + } + rt = RecordState { + stCryptState = cst + , stMacState = MacState { msSequence = 0 } + , stCipher = Just cipher + , stCompression = nullCompression + } + +setHelloParameters13 :: Cipher -> HandshakeM () +setHelloParameters13 cipher = do + modify $ \hst -> hst + { hstPendingCipher = Just cipher + , hstPendingCompression = nullCompression + , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst + } + where hashAlg = cipherHash cipher + updateDigest (Left bytes) = Right $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes + updateDigest (Right _) = error "cannot initialize digest with another digest" + +getCryptState :: Context -> Bool -> IO CryptState +getCryptState ctx isServer + | isServer = stCryptState <$> readMVar (ctxTxState ctx) + | otherwise = stCryptState <$> readMVar (ctxRxState ctx) + +getHandshakeContextHash :: Context -> IO ByteString +getHandshakeContextHash ctx = do + Just hst <- getHState ctx -- fixme + case hstHandshakeDigest hst of + Right hashCtx -> return $ hashFinal hashCtx + Left _ -> error "un-initialized handshake digest" + +setPendingActions :: Context -> [ByteString -> IO ()] -> IO () +setPendingActions ctx bss = + modifyMVar_ (ctxPendingActions ctx) (\_ -> return bss) + +popPendingAction :: Context -> IO (ByteString -> IO ()) +popPendingAction ctx = + modifyMVar (ctxPendingActions ctx) (\(bs:bss) -> return (bss,bs)) -- fixme diff --git a/core/Network/TLS/IO.hs b/core/Network/TLS/IO.hs index 022809c40..a77831149 100644 --- a/core/Network/TLS/IO.hs +++ b/core/Network/TLS/IO.hs @@ -9,16 +9,24 @@ module Network.TLS.IO ( checkValid , sendPacket + , sendPacket13 + , sendBytes13 , recvPacket + , recvPacket13 ) where import Network.TLS.Context.Internal import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.Record +import Network.TLS.Record.Types13 +import Network.TLS.Record.Disengage13 import Network.TLS.Packet import Network.TLS.Hooks import Network.TLS.Sending +import Network.TLS.Sending13 import Network.TLS.Receiving +import Network.TLS.Receiving13 import qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) @@ -30,7 +38,7 @@ import System.IO.Error (mkIOError, eofErrorType) checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx - unless established $ throwIO ConnectionNotEstablished + when (established == NotEstablished) $ throwIO ConnectionNotEstablished eofed <- ctxEOF ctx when eofed $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing @@ -130,3 +138,44 @@ sendPacket ctx pkt = do contextSend ctx dataToSend where isNonNullAppData (AppData b) = not $ B.null b isNonNullAppData _ = False + +sendPacket13 :: MonadIO m => Context -> Packet13 -> m () +sendPacket13 ctx pkt = do + edataToSend <- liftIO $ do + withLog ctx $ \logging -> loggingPacketSent logging (show pkt) + writePacket13 ctx pkt + case edataToSend of + Left err -> throwCore err + Right dataToSend -> sendBytes13 ctx dataToSend + +sendBytes13 :: MonadIO m => Context -> ByteString -> m () +sendBytes13 ctx dataToSend = liftIO $ do + withLog ctx $ \logging -> loggingIOSent logging dataToSend + contextSend ctx dataToSend + +recvRecord13 :: Context + -> IO (Either TLSError Record13) +recvRecord13 ctx = readExact ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) + where recvLengthE = either (return . Left) recvLength + recvLength header@(Header _ _ readlen) + | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded + | otherwise = + readExact ctx (fromIntegral readlen) >>= + either (return . Left) (getRecord header) + maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) + getRecord :: Header -> ByteString -> IO (Either TLSError Record13) + getRecord header content = do + liftIO $ withLog ctx $ \logging -> loggingIORecv logging header content + runRxState ctx $ disengageRecord13 $ rawToRecord13 header content + +recvPacket13 :: MonadIO m => Context -> m (Either TLSError Packet13) +recvPacket13 ctx = liftIO $ do + erecord <- recvRecord13 ctx + case erecord of + Left err -> return $ Left err + Right record -> do + pkt <- processPacket13 ctx record + case pkt of + Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p + _ -> return () + return pkt diff --git a/core/Network/TLS/KeySchedule.hs b/core/Network/TLS/KeySchedule.hs new file mode 100644 index 000000000..a6fb68cae --- /dev/null +++ b/core/Network/TLS/KeySchedule.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.KeySchedule ( + hkdfExtract + , hkdfExpandLabel + , deriveSecret + ) where + +import qualified Crypto.Hash as H +import Crypto.KDF.HKDF +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Network.TLS.Crypto +import Network.TLS.Wire + +---------------------------------------------------------------- + +hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString +hkdfExtract SHA1 salt ikm = convert ((extract salt ikm) :: PRK H.SHA1) +hkdfExtract SHA256 salt ikm = convert ((extract salt ikm) :: PRK H.SHA256) +hkdfExtract SHA384 salt ikm = convert ((extract salt ikm) :: PRK H.SHA384) +hkdfExtract SHA512 salt ikm = convert ((extract salt ikm) :: PRK H.SHA512) +hkdfExtract _ _ _ = error "hkdfExtract: unsupported hash" + +---------------------------------------------------------------- + +deriveSecret :: Hash -> ByteString -> ByteString -> ByteString -> ByteString +deriveSecret h secret label hashedMsgs = + hkdfExpandLabel h secret label hashedMsgs len + where + len = hashDigestSize h + +---------------------------------------------------------------- + +hkdfExpandLabel :: Hash + -> ByteString + -> ByteString + -> ByteString + -> Int + -> ByteString +hkdfExpandLabel h secret label hashValue len = expand' h secret hkdfLabel len + where + hkdfLabel :: ByteString + hkdfLabel = runPut $ do + putWord16 $ fromIntegral len + let tlsLabel = "TLS 1.3, " `BS.append` label + tlsLabelLen = BS.length tlsLabel + hashLen = BS.length hashValue -- not equal to len + putWord8 $ fromIntegral tlsLabelLen + putBytes $ tlsLabel + putWord8 $ fromIntegral hashLen + putBytes $ hashValue + +expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString +expand' SHA1 secret label len = expand ((extractSkip secret) :: PRK H.SHA1) label len +expand' SHA256 secret label len = expand ((extractSkip secret) :: PRK H.SHA256) label len +expand' SHA384 secret label len = expand ((extractSkip secret) :: PRK H.SHA384) label len +expand' SHA512 secret label len = expand ((extractSkip secret) :: PRK H.SHA512) label len +expand' _ _ _ _ = error "expand'" + +---------------------------------------------------------------- diff --git a/core/Network/TLS/Packet.hs b/core/Network/TLS/Packet.hs index 328db66f2..002738b16 100644 --- a/core/Network/TLS/Packet.hs +++ b/core/Network/TLS/Packet.hs @@ -57,6 +57,11 @@ module Network.TLS.Packet -- * for extensions parsing , getSignatureHashAlgorithm , putSignatureHashAlgorithm + , getVersion' + , putVersion' + , putServerRandom32 + , putExtension + , getExtensions ) where import Network.TLS.Imports @@ -93,8 +98,14 @@ getVersion = do Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) Just v -> return v -putVersion :: Version -> Put -putVersion ver = putWord8 major >> putWord8 minor +getVersion' :: Get (Maybe Version) +getVersion' = do + major <- getWord8 + minor <- getWord8 + return $ verOfNum (major, minor) + +putVersion' :: Version -> Put +putVersion' ver = putWord8 major >> putWord8 minor where (major, minor) = numericalVer ver getHeaderType :: Get ProtocolType @@ -131,7 +142,7 @@ decodeDeprecatedHeader size = return $ Header ProtocolType_DeprecatedHandshake version size encodeHeader :: Header -> ByteString -encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len) +encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion' ver >> putWord16 len) {- FIXME check len <= 2^14 -} encodeHeaderNoVer :: Header -> ByteString @@ -181,6 +192,7 @@ decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_CertVerify -> decodeCertVerify cp HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp HandshakeType_Finished -> decodeFinished + HandshakeType_HelloRetryRequest -> decodeHelloRetryRequest decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b @@ -224,14 +236,19 @@ decodeServerHello :: Get Handshake decodeServerHello = do ver <- getVersion random <- getServerRandom32 - session <- getSession - cipherid <- getWord16 - compressionid <- getWord8 - r <- remaining - exts <- if hasHelloExtensions ver && r > 0 - then fmap fromIntegral getWord16 >>= getExtensions - else return [] - return $ ServerHello ver random session cipherid compressionid exts + if ver <= TLS12 then do + session <- getSession + cipherid <- getWord16 + compressionid <- getWord8 + r <- remaining + exts <- if hasHelloExtensions ver && r > 0 + then fmap fromIntegral getWord16 >>= getExtensions + else return [] + return $ ServerHello ver random session cipherid compressionid exts + else do + cipherid <- getWord16 + exts <- fmap fromIntegral getWord16 >>= getExtensions + return $ ServerHello' ver random cipherid exts decodeServerHelloDone :: Get Handshake decodeServerHelloDone = return ServerHelloDone @@ -331,6 +348,12 @@ decodeServerKeyXchg cp = Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) +decodeHelloRetryRequest :: Get Handshake +decodeHelloRetryRequest = do + ver <- getVersion + exts <- (fromIntegral <$> getWord16) >>= getExtensions + return $ HelloRetryRequest ver exts + encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = runPut $ encodeHandshakeContent o in @@ -351,7 +374,7 @@ encodeHandshakeContent :: Handshake -> Put encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do putBytes deprecated encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do - putVersion version + putVersion' version putClientRandom32 random putSession session putWords16 cipherIDs @@ -360,9 +383,9 @@ encodeHandshakeContent (ClientHello version random session cipherIDs compression return () encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) = - putVersion version >> putServerRandom32 random >> putSession session - >> putWord16 cipherid >> putWord8 compressionID - >> putExtensions exts >> return () + putVersion' version >> putServerRandom32 random >> putSession session + >> putWord16 cipherid >> putWord8 compressionID + >> putExtensions exts >> return () encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs) where (CertificateChainRaw certs) = encodeCertificateChain cc @@ -407,6 +430,15 @@ encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digital encodeHandshakeContent (Finished opaque) = putBytes opaque +encodeHandshakeContent (ServerHello' ver random cipherId exts) = do + putVersion' ver + putServerRandom32 random + putWord16 cipherId + putExtensions exts -- fixme +encodeHandshakeContent (HelloRetryRequest ver exts) = do + putVersion' ver + putExtensions exts -- fixme + {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get ByteString getRandom32 = getBytes 32 @@ -469,6 +501,7 @@ getServerDHParams = ServerDHParams <$> getBigNum16 <*> getBigNum16 <*> getBigNum putServerDHParams :: ServerDHParams -> Put putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p,g,y] +-- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do curveType <- getWord8 @@ -485,6 +518,7 @@ getServerECDHParams = do _ -> error "getServerECDHParams: unknown type for ECDH Params" +-- RFC 4492 Section 5.4 Server Key Exchange putServerECDHParams :: ServerECDHParams -> Put putServerECDHParams (ServerECDHParams grp grppub) = do putWord8 3 -- ECParameters ECCurveType @@ -519,7 +553,7 @@ decodePreMasterSecret = runGetErr "pre-master-secret" $ do liftM2 (,) getVersion (getBytes 46) encodePreMasterSecret :: Version -> ByteString -> ByteString -encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes) +encodePreMasterSecret version bytes = runPut (putVersion' version >> putBytes bytes) -- | in certain cases, we haven't manage to decode ServerKeyExchange properly, -- because the decoding was too eager and the cipher wasn't been set yet. diff --git a/core/Network/TLS/Packet13.hs b/core/Network/TLS/Packet13.hs new file mode 100644 index 000000000..48426d0a1 --- /dev/null +++ b/core/Network/TLS/Packet13.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Packet13 where + +import Control.Applicative +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Packet +import Network.TLS.Wire +import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) + +encodeHandshakes13 :: [Handshake13] -> ByteString +encodeHandshakes13 hss = B.concat $ map encodeHandshake13 hss + +encodeHandshake13 :: Handshake13 -> ByteString +encodeHandshake13 hdsk = pkt + where + !tp = typeOfHandshake13 hdsk + !content = encodeHandshake13' hdsk + !len = fromIntegral $ B.length content + !header = encodeHandshakeHeader13 tp len + !pkt = B.concat [header, content] + +-- TLS 1.3 does not use "select (extensions_present)". +putExtensions :: [ExtensionRaw] -> Put +putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) + +encodeHandshake13' :: Handshake13 -> ByteString +encodeHandshake13' (HelloRetryRequest13 ver exts) = runPut $ do + putVersion' ver + putExtensions exts +encodeHandshake13' (ServerHello13 ver random cipherId exts) = runPut $ do + putVersion' ver + putServerRandom32 random + putWord16 cipherId + putExtensions exts +encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts +encodeHandshake13' (Certificate13 reqctx cc ess) = runPut $ do + putOpaque8 reqctx + putOpaque24 (runPut $ mapM_ putCert $ zip certs ess) + where + CertificateChainRaw certs = encodeCertificateChain cc + putCert (certRaw,exts) = do + putOpaque24 certRaw + putExtensions exts +encodeHandshake13' (CertVerify13 hs signature) = runPut $ do + putSignatureHashAlgorithm hs + putOpaque16 signature +encodeHandshake13' (Finished13 dat) = runPut $ putBytes dat +encodeHandshake13' (NewSessionTicket13 life ageadd ticket exts) = runPut $ do + putWord32 life + putWord32 ageadd + putOpaque16 ticket + putExtensions exts +encodeHandshake13' _ = error "encodeHandshake13'" + +encodeHandshakeHeader13 :: HandshakeType13 -> Int -> ByteString +encodeHandshakeHeader13 ty len = runPut $ do + putWord8 (valOfType ty) + putWord24 len + + +{- decode and encode HANDSHAKE -} +getHandshakeType13 :: Get HandshakeType13 +getHandshakeType13 = do + ty <- getWord8 + case valToType ty of + Nothing -> fail ("invalid handshake type: " ++ show ty) + Just t -> return t + +decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType13, ByteString) +decodeHandshakeRecord13 = runGet "handshake-record" $ do + ty <- getHandshakeType13 + content <- getOpaque24 + return (ty, content) + +decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake13 +decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of + HandshakeType_Finished13 -> decodeFinished13 + HandshakeType_EncryptedExtensions13 -> decodeEncryptedExtensions13 + HandshakeType_Certificate13 -> decodeCertificate13 + HandshakeType_CertVerify13 -> decodeCertVerify13 + HandshakeType_NewSessionTicket13 -> decodeNewSessionTicket13 + _x -> error $ "decodeHandshake13 " ++ show _x + +decodeFinished13 :: Get Handshake13 +decodeFinished13 = Finished13 <$> (remaining >>= getBytes) + +decodeEncryptedExtensions13 :: Get Handshake13 +decodeEncryptedExtensions13 = EncryptedExtensions13 <$> do + len <- fromIntegral <$> getWord16 + getExtensions len + +decodeCertificate13 :: Get Handshake13 +decodeCertificate13 = do + reqctx <- getOpaque8 + len <- fromIntegral <$> getWord24 + (certRaws, ess) <- unzip <$> getList len getCert + let Right certs = decodeCertificateChain $ CertificateChainRaw certRaws -- fixme + return $ Certificate13 reqctx certs ess + where + getCert = do + l <- fromIntegral <$> getWord24 + cert <- getBytes l + len <- fromIntegral <$> getWord16 + exts <- getExtensions len + return (3 + l + 2 + len, (cert, exts)) + +decodeCertVerify13 :: Get Handshake13 +decodeCertVerify13 = do + hs <- getSignatureHashAlgorithm + signature <- getOpaque16 + return $ CertVerify13 hs signature + +decodeNewSessionTicket13 :: Get Handshake13 +decodeNewSessionTicket13 = do + life <- getWord32 + ageadd <- getWord32 + ticket <- getOpaque16 + len <- fromIntegral <$> getWord16 + exts <- getExtensions len + return $ NewSessionTicket13 life ageadd ticket exts diff --git a/core/Network/TLS/Parameters.hs b/core/Network/TLS/Parameters.hs index 4b446a8ab..f14c9f65f 100644 --- a/core/Network/TLS/Parameters.hs +++ b/core/Network/TLS/Parameters.hs @@ -93,6 +93,7 @@ data ClientParams = ClientParams -- of 'supportedCiphers' with a suitable cipherlist. , clientSupported :: Supported , clientDebug :: DebugParams + , clientTLS13ZeroRttData :: Maybe ByteString } deriving (Show) defaultParamsClient :: HostName -> ByteString -> ClientParams @@ -105,6 +106,7 @@ defaultParamsClient serverName serverId = ClientParams , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams + , clientTLS13ZeroRttData = Nothing } data ServerParams = ServerParams @@ -198,7 +200,10 @@ defaultSupported = Supported { supportedVersions = [TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression] - , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA) + , supportedHashSignatures = [ (HashTLS13, SignatureRSApssSHA256) + , (HashTLS13, SignatureRSApssSHA384) + , (HashTLS13, SignatureRSApssSHA512) + , (Struct.HashSHA512, SignatureRSA) , (Struct.HashSHA512, SignatureECDSA) , (Struct.HashSHA384, SignatureRSA) , (Struct.HashSHA384, SignatureECDSA) diff --git a/core/Network/TLS/Receiving13.hs b/core/Network/TLS/Receiving13.hs new file mode 100644 index 000000000..bfac24f8a --- /dev/null +++ b/core/Network/TLS/Receiving13.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Network.TLS.Receiving +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Receiving module contains calls related to unmarshalling packets according +-- to the TLS state +-- +{-# LANGUAGE FlexibleContexts #-} + +module Network.TLS.Receiving13 (processPacket13) where + +import Control.Monad.State + +import Network.TLS.Context.Internal +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.ErrT +import Network.TLS.Record.Types13 +import Network.TLS.Packet +import Network.TLS.Packet13 +import Network.TLS.Wire +import Network.TLS.State +import Network.TLS.Util + +processPacket13 :: Context -> Record13 -> IO (Either TLSError Packet13) +processPacket13 _ (Record13 ContentType_AppData fragment) = return $ Right $ AppData13 fragment +processPacket13 _ (Record13 ContentType_Alert fragment) = return (Alert13 `fmapEither` (decodeAlerts fragment)) +processPacket13 ctx (Record13 ContentType_Handshake fragment) = usingState ctx $ do + mCont <- gets stHandshakeRecordCont13 + modify (\st -> st { stHandshakeRecordCont13 = Nothing }) + hss <- parseMany mCont fragment + return $ Handshake13 hss + where parseMany mCont bs = + case maybe decodeHandshakeRecord13 id mCont $ bs of + GotError err -> throwError err + GotPartial cont -> modify (\st -> st { stHandshakeRecordCont13 = Just cont }) >> return [] + GotSuccess (ty,content) -> + either throwError (return . (:[])) $ decodeHandshake13 ty content + GotSuccessRemaining (ty,content) left -> + case decodeHandshake13 ty content of + Left err -> throwError err + Right hh -> (hh:) `fmap` parseMany Nothing left diff --git a/core/Network/TLS/Record/Disengage13.hs b/core/Network/TLS/Record/Disengage13.hs new file mode 100644 index 000000000..314737c9e --- /dev/null +++ b/core/Network/TLS/Record/Disengage13.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.TLS.Record.Disengage +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Disengage a record from the Record layer. +-- The record is decrypted, checked for integrity and then decompressed. +-- +{-# LANGUAGE FlexibleContexts #-} + +module Network.TLS.Record.Disengage13 + ( disengageRecord13 + ) where + +import Control.Monad.State + +import Data.Bits +import Network.TLS.Imports +import Crypto.Cipher.Types (AuthTag(..)) +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.ErrT +import Network.TLS.Record.State +import Network.TLS.Record.Types13 +import Network.TLS.Cipher +import Network.TLS.Util +import Network.TLS.Wire +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteArray as B (convert) + +disengageRecord13 :: Record13 -> RecordM Record13 +disengageRecord13 record@(Record13 ContentType_AppData e) = do + st <- get + case stCipher st of + Nothing -> return record + _ -> do + inner <- decryptData e st + let (dc,_pad) = B.spanEnd (== 0) inner + Just (d,c) = B.unsnoc dc + Just ct = valToType c + return $ Record13 ct d +disengageRecord13 record = return record + +decryptData :: ByteString -> RecordState -> RecordM ByteString +decryptData econtent tst = decryptOf (cstKey cst) + where cipher = fromJust "cipher" $ stCipher tst + bulk = cipherBulk cipher + cst = stCryptState tst + econtentLen = B.length econtent + + decryptOf :: BulkState -> RecordM ByteString + decryptOf (BulkStateAEAD decryptF) = do + let authTagLen = bulkAuthTagLen bulk + cipherLen = econtentLen - authTagLen + + (econtent', authTag) <- get2 econtent (cipherLen, authTagLen) + let encodedSeq = encodeWord64 $ msSequence $ stMacState tst + iv = cstIV cst + ivlen = B.length iv + sqnc = B.pack (replicate (ivlen - 8) 0) `B.append` encodedSeq + nonce = B.pack $ B.zipWith xor iv sqnc + (content, authTag2) = decryptF nonce econtent' "" + + when (AuthTag (B.convert authTag) /= authTag2) $ + throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) + modify incrRecordState + return content + + decryptOf _ = + throwError $ Error_Protocol ("decrypt state uninitialized", True, InternalError) + + get3 s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls + get2 s (d1,d2) = get3 s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2) diff --git a/core/Network/TLS/Record/Engage13.hs b/core/Network/TLS/Record/Engage13.hs new file mode 100644 index 000000000..7082c7e62 --- /dev/null +++ b/core/Network/TLS/Record/Engage13.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.TLS.Record.Engage +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Engage a record into the Record layer. +-- The record is compressed, added some integrity field, then encrypted. +-- +{-# LANGUAGE BangPatterns #-} +module Network.TLS.Record.Engage13 + ( engageRecord + ) where + +import Control.Applicative +import Control.Monad.State +import Crypto.Cipher.Types (AuthTag(..)) + +import Data.Bits (xor) +import Network.TLS.Record.State +import Network.TLS.Record.Types13 +import Network.TLS.Cipher +import Network.TLS.Wire +import Network.TLS.Struct (valOfType) +import Network.TLS.Struct13 +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteArray as B (convert) + +engageRecord :: Record13 -> RecordM Record13 +engageRecord record@(Record13 ct bytes) = do + st <- get + case stCipher st of + Nothing -> return record + _ -> do + ebytes <- encryptContent $ innerPlaintext ct bytes + return $ Record13 ContentType_AppData ebytes + +innerPlaintext :: ContentType -> ByteString -> ByteString +innerPlaintext ct bytes = runPut $ do + putBytes bytes + putWord8 $ valOfType ct -- non zero! + -- fixme: zeros padding + +encryptContent :: ByteString -> RecordM ByteString +encryptContent content = do + cst <- stCryptState <$> get + case cstKey cst of + BulkStateBlock _ -> error "encryptContent" + BulkStateStream _ -> error "encryptContent" + BulkStateUninitialized -> return content + BulkStateAEAD encryptF -> do + encodedSeq <- encodeWord64 <$> getMacSequence + let iv = cstIV cst + ivlen = B.length iv + sqnc = B.pack (replicate (ivlen - 8) 0) `B.append` encodedSeq + nonce = B.pack $ B.zipWith xor iv sqnc + (e, AuthTag authtag) = encryptF nonce content "" + econtent = e `B.append` B.convert authtag + modify incrRecordState + return econtent diff --git a/core/Network/TLS/Record/Types13.hs b/core/Network/TLS/Record/Types13.hs new file mode 100644 index 000000000..83427787e --- /dev/null +++ b/core/Network/TLS/Record/Types13.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Network.TLS.Record.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- + +module Network.TLS.Record.Types13 where + +import Data.ByteString (ByteString) +import Network.TLS.Struct13 +import Network.TLS.Record.Types (Header(..)) + +-- | Represent a TLS record. +data Record13 = Record13 !ContentType ByteString deriving (Show,Eq) + +-- | turn a header and a fragment into a record +rawToRecord13 :: Header -> ByteString -> Record13 +rawToRecord13 (Header pt _ _) fragment = Record13 (protoToContent pt) fragment diff --git a/core/Network/TLS/Sending13.hs b/core/Network/TLS/Sending13.hs new file mode 100644 index 000000000..5c47ea587 --- /dev/null +++ b/core/Network/TLS/Sending13.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Network.TLS.Sending +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Sending module contains calls related to marshalling packets according +-- to the TLS state +-- +module Network.TLS.Sending13 (writePacket13, writeHandshakePacket13) where + +import Control.Monad.State + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B + +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Record (RecordM) +import Network.TLS.Record.Types13 +import Network.TLS.Record.Engage13 +import Network.TLS.Packet +import Network.TLS.Packet13 +import Network.TLS.Hooks +import Network.TLS.Context.Internal +import Network.TLS.Handshake.State +import Network.TLS.Wire + +makeRecord :: Packet13 -> RecordM Record13 +makeRecord pkt = return $ Record13 (contentType pkt) $ writePacketContent pkt + where writePacketContent (Handshake13 hss) = encodeHandshakes13 hss + writePacketContent (Alert13 a) = encodeAlerts a + writePacketContent (AppData13 x) = x + +encodeRecord :: Record13 -> RecordM ByteString +encodeRecord (Record13 ct bytes) = return ebytes + where + ebytes = runPut $ do + putWord8 $ fromIntegral $ valOfType ct + putWord16 0x0301 + putWord16 $ fromIntegral $ B.length bytes + putBytes bytes + +writePacket13 :: Context -> Packet13 -> IO (Either TLSError ByteString) +writePacket13 ctx pkt@(Handshake13 hss) = do + forM_ hss $ \hs -> usingHState ctx $ do + let encoded = encodeHandshake13 hs + updateHandshakeDigest encoded + addHandshakeMessage encoded + prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord) +writePacket13 ctx pkt = prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord) + +writeHandshakePacket13 :: MonadIO m => Context -> Handshake13 -> m ByteString +writeHandshakePacket13 ctx hdsk = do + let pkt = Handshake13 [hdsk] + edataToSend <- liftIO $ do + withLog ctx $ \logging -> loggingPacketSent logging (show pkt) + writePacket13 ctx pkt + case edataToSend of + Left err -> throwCore err + Right dataToSend -> return dataToSend + +prepareRecord :: Context -> RecordM a -> IO (Either TLSError a) +prepareRecord = runTxState diff --git a/core/Network/TLS/State.hs b/core/Network/TLS/State.hs index 7a5659fa7..37d863077 100644 --- a/core/Network/TLS/State.hs +++ b/core/Network/TLS/State.hs @@ -53,6 +53,7 @@ module Network.TLS.State import Network.TLS.Imports import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.RNG import Network.TLS.Types (Role(..)) import Network.TLS.Wire (GetContinuation) @@ -75,6 +76,7 @@ data TLSState = TLSState , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol + , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType13, ByteString)) , stClientALPNSuggest :: Maybe [B.ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] @@ -107,9 +109,10 @@ newTLSState rng clientContext = TLSState , stServerVerifiedData = B.empty , stExtensionALPN = False , stHandshakeRecordCont = Nothing + , stHandshakeRecordCont13 = Nothing , stNegotiatedProtocol = Nothing , stClientALPNSuggest = Nothing - , stClientGroupSuggest = Nothing + , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stClientSNI = Nothing @@ -136,6 +139,7 @@ finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True finishHandshakeTypeMaterial HandshakeType_CertRequest = True finishHandshakeTypeMaterial HandshakeType_CertVerify = True finishHandshakeTypeMaterial HandshakeType_Finished = True +finishHandshakeTypeMaterial HandshakeType_HelloRetryRequest = True -- fixme finishHandshakeMaterial :: Handshake -> Bool finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake @@ -151,6 +155,7 @@ certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False certVerifyHandshakeTypeMaterial HandshakeType_Finished = False +certVerifyHandshakeTypeMaterial HandshakeType_HelloRetryRequest = True -- fixme certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake diff --git a/core/Network/TLS/Struct.hs b/core/Network/TLS/Struct.hs index d99f3607f..40a0fffb2 100644 --- a/core/Network/TLS/Struct.hs +++ b/core/Network/TLS/Struct.hs @@ -206,6 +206,7 @@ data AlertLevel = data AlertDescription = CloseNotify + | EndOfEarlyData | UnexpectedMessage | BadRecordMac | DecryptionFailed -- ^ deprecated alert, should never be sent by compliant implementation @@ -229,11 +230,14 @@ data AlertDescription = | InappropriateFallback -- RFC7507 | UserCanceled | NoRenegotiation + | MissingExtension | UnsupportedExtension | CertificateUnobtainable | UnrecognizedName | BadCertificateStatusResponse | BadCertificateHashValue + | UnknownPskIdentity + | CertificateRequired deriving (Show,Eq) data HandshakeType = @@ -247,6 +251,7 @@ data HandshakeType = | HandshakeType_CertVerify | HandshakeType_ClientKeyXchg | HandshakeType_Finished + | HandshakeType_HelloRetryRequest deriving (Show,Eq) newtype BigNum = BigNum ByteString @@ -319,6 +324,8 @@ data Handshake = | CertRequest [CertificateType] (Maybe [HashAndSignatureAlgorithm]) [DistinguishedName] | CertVerify DigitallySigned | Finished FinishedData + | ServerHello' !Version !ServerRandom !CipherID [ExtensionRaw] -- TLS 1.3 + | HelloRetryRequest !Version [ExtensionRaw] -- TLS 1.3 deriving (Show,Eq) packetType :: Packet -> ProtocolType @@ -338,6 +345,8 @@ typeOfHandshake (ServerKeyXchg {}) = HandshakeType_ServerKeyXchg typeOfHandshake (CertRequest {}) = HandshakeType_CertRequest typeOfHandshake (CertVerify {}) = HandshakeType_CertVerify typeOfHandshake (Finished {}) = HandshakeType_Finished +typeOfHandshake (ServerHello' {}) = HandshakeType_ServerHello +typeOfHandshake (HelloRetryRequest {}) = HandshakeType_HelloRetryRequest numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0) @@ -345,6 +354,8 @@ numericalVer SSL3 = (3, 0) numericalVer TLS10 = (3, 1) numericalVer TLS11 = (3, 2) numericalVer TLS12 = (3, 3) +numericalVer TLS13ID18 = (0x7f, 0x12) +numericalVer TLS13 = (3, 4) verOfNum :: (Word8, Word8) -> Maybe Version verOfNum (2, 0) = Just SSL2 @@ -352,6 +363,8 @@ verOfNum (3, 0) = Just SSL3 verOfNum (3, 1) = Just TLS10 verOfNum (3, 2) = Just TLS11 verOfNum (3, 3) = Just TLS12 +verOfNum (3, 4) = Just TLS13 +verOfNum (0x7f, 0x12) = Just TLS13ID18 verOfNum _ = Nothing class TypeValuable a where @@ -399,20 +412,22 @@ instance TypeValuable ProtocolType where valToType _ = Nothing instance TypeValuable HandshakeType where - valOfType HandshakeType_HelloRequest = 0 - valOfType HandshakeType_ClientHello = 1 - valOfType HandshakeType_ServerHello = 2 - valOfType HandshakeType_Certificate = 11 - valOfType HandshakeType_ServerKeyXchg = 12 - valOfType HandshakeType_CertRequest = 13 - valOfType HandshakeType_ServerHelloDone = 14 - valOfType HandshakeType_CertVerify = 15 - valOfType HandshakeType_ClientKeyXchg = 16 - valOfType HandshakeType_Finished = 20 + valOfType HandshakeType_HelloRequest = 0 + valOfType HandshakeType_ClientHello = 1 + valOfType HandshakeType_ServerHello = 2 + valOfType HandshakeType_HelloRetryRequest = 6 + valOfType HandshakeType_Certificate = 11 + valOfType HandshakeType_ServerKeyXchg = 12 + valOfType HandshakeType_CertRequest = 13 + valOfType HandshakeType_ServerHelloDone = 14 + valOfType HandshakeType_CertVerify = 15 + valOfType HandshakeType_ClientKeyXchg = 16 + valOfType HandshakeType_Finished = 20 valToType 0 = Just HandshakeType_HelloRequest valToType 1 = Just HandshakeType_ClientHello valToType 2 = Just HandshakeType_ServerHello + valToType 6 = Just HandshakeType_HelloRetryRequest valToType 11 = Just HandshakeType_Certificate valToType 12 = Just HandshakeType_ServerKeyXchg valToType 13 = Just HandshakeType_CertRequest @@ -432,6 +447,7 @@ instance TypeValuable AlertLevel where instance TypeValuable AlertDescription where valOfType CloseNotify = 0 + valOfType EndOfEarlyData = 1 valOfType UnexpectedMessage = 10 valOfType BadRecordMac = 20 valOfType DecryptionFailed = 21 @@ -455,13 +471,17 @@ instance TypeValuable AlertDescription where valOfType InappropriateFallback = 86 valOfType UserCanceled = 90 valOfType NoRenegotiation = 100 + valOfType MissingExtension = 109 valOfType UnsupportedExtension = 110 valOfType CertificateUnobtainable = 111 valOfType UnrecognizedName = 112 valOfType BadCertificateStatusResponse = 113 valOfType BadCertificateHashValue = 114 + valOfType UnknownPskIdentity = 115 + valOfType CertificateRequired = 116 valToType 0 = Just CloseNotify + valToType 1 = Just EndOfEarlyData valToType 10 = Just UnexpectedMessage valToType 20 = Just BadRecordMac valToType 21 = Just DecryptionFailed @@ -485,11 +505,14 @@ instance TypeValuable AlertDescription where valToType 86 = Just InappropriateFallback valToType 90 = Just UserCanceled valToType 100 = Just NoRenegotiation + valToType 109 = Just MissingExtension valToType 110 = Just UnsupportedExtension valToType 111 = Just CertificateUnobtainable valToType 112 = Just UnrecognizedName valToType 113 = Just BadCertificateStatusResponse valToType 114 = Just BadCertificateHashValue + valToType 115 = Just UnknownPskIdentity + valToType 116 = Just CertificateRequired valToType _ = Nothing instance TypeValuable CertificateType where diff --git a/core/Network/TLS/Struct13.hs b/core/Network/TLS/Struct13.hs new file mode 100644 index 000000000..3be280404 --- /dev/null +++ b/core/Network/TLS/Struct13.hs @@ -0,0 +1,106 @@ +module Network.TLS.Struct13 where + +import Data.ByteString (ByteString) +import Data.Word +import Data.X509 (CertificateChain) +import Network.TLS.Struct +import Network.TLS.Types + +data Packet13 = + Handshake13 [Handshake13] + | Alert13 [(AlertLevel, AlertDescription)] + | AppData13 ByteString + deriving (Show,Eq) + +data CertificateEntry13 = CertificateEntry13 [ExtensionRaw] + deriving (Show,Eq) + +data Handshake13 = + ClientHello13 !Version !ClientRandom ![CipherID] [ExtensionRaw] + | ServerHello13 !Version !ServerRandom !CipherID [ExtensionRaw] + | NewSessionTicket13 Word32 Word32 ByteString [ExtensionRaw] -- fixme + | HelloRetryRequest13 !Version [ExtensionRaw] + | EncryptedExtensions13 [ExtensionRaw] + | CertRequest13 -- fixme + | Certificate13 ByteString CertificateChain [[ExtensionRaw]] + | CertVerify13 HashAndSignatureAlgorithm ByteString + | Finished13 FinishedData + | KeyUpdate13 -- fixme + deriving (Show,Eq) + +data HandshakeType13 = + HandshakeType_ClientHello13 + | HandshakeType_ServerHello13 + | HandshakeType_NewSessionTicket13 + | HandshakeType_HelloRetryRequest13 + | HandshakeType_EncryptedExtensions13 + | HandshakeType_CertRequest13 + | HandshakeType_Certificate13 + | HandshakeType_CertVerify13 + | HandshakeType_Finished13 + | HandshakeType_KeyUpdate13 + deriving (Show,Eq) + +typeOfHandshake13 :: Handshake13 -> HandshakeType13 +typeOfHandshake13 (ClientHello13 {}) = HandshakeType_ClientHello13 +typeOfHandshake13 (ServerHello13 {}) = HandshakeType_ServerHello13 +typeOfHandshake13 (NewSessionTicket13 {}) = HandshakeType_NewSessionTicket13 +typeOfHandshake13 (HelloRetryRequest13 {}) = HandshakeType_HelloRetryRequest13 +typeOfHandshake13 (EncryptedExtensions13 {}) = HandshakeType_EncryptedExtensions13 +typeOfHandshake13 (CertRequest13 {}) = HandshakeType_CertRequest13 +typeOfHandshake13 (Certificate13 {}) = HandshakeType_Certificate13 +typeOfHandshake13 (CertVerify13 {}) = HandshakeType_CertVerify13 +typeOfHandshake13 (Finished13 {}) = HandshakeType_Finished13 +typeOfHandshake13 (KeyUpdate13 {}) = HandshakeType_KeyUpdate13 + +instance TypeValuable HandshakeType13 where + valOfType HandshakeType_ClientHello13 = 1 + valOfType HandshakeType_ServerHello13 = 2 + valOfType HandshakeType_NewSessionTicket13 = 4 + valOfType HandshakeType_HelloRetryRequest13 = 6 + valOfType HandshakeType_EncryptedExtensions13 = 8 + valOfType HandshakeType_CertRequest13 = 13 + valOfType HandshakeType_Certificate13 = 11 + valOfType HandshakeType_CertVerify13 = 15 + valOfType HandshakeType_Finished13 = 20 + valOfType HandshakeType_KeyUpdate13 = 24 + + valToType 1 = Just HandshakeType_ClientHello13 + valToType 2 = Just HandshakeType_ServerHello13 + valToType 4 = Just HandshakeType_NewSessionTicket13 + valToType 6 = Just HandshakeType_HelloRetryRequest13 + valToType 8 = Just HandshakeType_EncryptedExtensions13 + valToType 13 = Just HandshakeType_CertRequest13 + valToType 11 = Just HandshakeType_Certificate13 + valToType 15 = Just HandshakeType_CertVerify13 + valToType 20 = Just HandshakeType_Finished13 + valToType 24 = Just HandshakeType_KeyUpdate13 + valToType _ = Nothing + +data ContentType = + ContentType_Alert + | ContentType_Handshake + | ContentType_AppData + deriving (Eq, Show) + + +instance TypeValuable ContentType where + valOfType ContentType_Alert = 21 + valOfType ContentType_Handshake = 22 + valOfType ContentType_AppData = 23 + + valToType 21 = Just ContentType_Alert + valToType 22 = Just ContentType_Handshake + valToType 23 = Just ContentType_AppData + valToType _ = Nothing + +contentType :: Packet13 -> ContentType +contentType (Handshake13 _) = ContentType_Handshake +contentType (Alert13 _) = ContentType_Alert +contentType (AppData13 _) = ContentType_AppData + +protoToContent :: ProtocolType -> ContentType +protoToContent ProtocolType_Alert = ContentType_Alert +protoToContent ProtocolType_Handshake = ContentType_Handshake +protoToContent ProtocolType_AppData = ContentType_AppData +protoToContent _ = error "protoToContent" diff --git a/core/Network/TLS/Types.hs b/core/Network/TLS/Types.hs index 0aed110e2..6c86fde19 100644 --- a/core/Network/TLS/Types.hs +++ b/core/Network/TLS/Types.hs @@ -8,27 +8,35 @@ module Network.TLS.Types ( Version(..) , SessionID + , SessionLabel , SessionData(..) + , TLS13TicketInfo(..) , CipherID , CompressionID , Role(..) , invertRole , Direction(..) +-- , HostName ) where import Data.ByteString (ByteString) import Data.Word +import Network.TLS.Crypto.Types (Group) type HostName = String -- | Versions known to TLS -- -- SSL2 is just defined, but this version is and will not be supported. -data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord, Bounded) +data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 | TLS13ID18 | TLS13 deriving (Show, Eq, Ord, Bounded) -- | A session ID type SessionID = ByteString +-- | A session ticket label. +-- This is an alias to 'SessionID'. +type SessionLabel = SessionID + -- | Session data to resume data SessionData = SessionData { sessionVersion :: Version @@ -36,6 +44,14 @@ data SessionData = SessionData , sessionCompression :: CompressionID , sessionClientSNI :: Maybe HostName , sessionSecret :: ByteString + , sessionGroup :: Maybe Group + , sessionTicketInfo :: Maybe TLS13TicketInfo + } deriving (Show,Eq) + +data TLS13TicketInfo = TLS13TicketInfo + { lifetime :: Word32 -- NewSessionTicket.ticket_lifetime in seconds + , ageAdd :: Word32 -- NewSessionTicket.ticket_age_add + , txrxTime :: Word64 -- serverSendTime or clientReceiveTime in milliseconds } deriving (Show,Eq) -- | Cipher identification diff --git a/core/Network/TLS/Wire.hs b/core/Network/TLS/Wire.hs index 0d3c0ff5a..37bc22bb9 100644 --- a/core/Network/TLS/Wire.hs +++ b/core/Network/TLS/Wire.hs @@ -23,6 +23,7 @@ module Network.TLS.Wire , getWords16 , getWord24 , getWord32 + , getWord64 , getBytes , getOpaque8 , getOpaque16 @@ -40,6 +41,7 @@ module Network.TLS.Wire , putWords16 , putWord24 , putWord32 + , putWord64 , putBytes , putOpaque8 , putOpaque16 @@ -110,6 +112,9 @@ getWord24 = do getWord32 :: Get Word32 getWord32 = getWord32be +getWord64 :: Get Word64 +getWord64 = getWord64be + getOpaque8 :: Get ByteString getOpaque8 = getWord8 >>= getBytes . fromIntegral @@ -146,6 +151,9 @@ putWord16 = putWord16be putWord32 :: Word32 -> Put putWord32 = putWord32be +putWord64 :: Word64 -> Put +putWord64 = putWord64be + putWords16 :: [Word16] -> Put putWords16 l = do putWord16 $ 2 * (fromIntegral $ length l) diff --git a/core/tls.cabal b/core/tls.cabal index 85dee345a..0d59c55fe 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -56,6 +56,7 @@ Library , x509-store >= 1.6 , x509-validation >= 1.6.5 && < 1.7.0 , async >= 2.0 + , time if flag(network) Build-Depends: network >= 2.4.0.0 cpp-options: -DINCLUDE_NETWORK @@ -71,6 +72,7 @@ Library Network.TLS.Extra.FFDHE other-modules: Network.TLS.Cap Network.TLS.Struct + Network.TLS.Struct13 Network.TLS.Core Network.TLS.Context Network.TLS.Context.Internal @@ -84,6 +86,7 @@ Library Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Common + Network.TLS.Handshake.Common13 Network.TLS.Handshake.Certificate Network.TLS.Handshake.Key Network.TLS.Handshake.Client @@ -91,23 +94,31 @@ Library Network.TLS.Handshake.Process Network.TLS.Handshake.Signature Network.TLS.Handshake.State + Network.TLS.Handshake.State13 Network.TLS.Hooks Network.TLS.IO Network.TLS.Imports + Network.TLS.KeySchedule Network.TLS.MAC Network.TLS.Measurement Network.TLS.Packet + Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.Record Network.TLS.Record.Types + Network.TLS.Record.Types13 Network.TLS.Record.Engage + Network.TLS.Record.Engage13 Network.TLS.Record.Disengage + Network.TLS.Record.Disengage13 Network.TLS.Record.State Network.TLS.RNG Network.TLS.State Network.TLS.Session Network.TLS.Sending + Network.TLS.Sending13 Network.TLS.Receiving + Network.TLS.Receiving13 Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization diff --git a/debug/src/SimpleClient.hs b/debug/src/SimpleClient.hs index 94d5d3d8f..405160b19 100644 --- a/debug/src/SimpleClient.hs +++ b/debug/src/SimpleClient.hs @@ -13,6 +13,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B import Control.Exception import qualified Control.Exception as E +import Control.Applicative import Control.Monad import System.Environment import System.Exit @@ -22,7 +23,11 @@ import Data.Default.Class import Data.IORef import Data.Monoid import Data.List (find) -import Data.Maybe (isJust, mapMaybe) +import Data.Char (isDigit) +import Data.Maybe (isJust, catMaybes, mapMaybe) + +import Numeric (showHex) + import Common import HexDump @@ -62,9 +67,12 @@ sessionRef ref = SessionManager , sessionInvalidate = \_ -> return () } -getDefaultParams flags host store sStorage certCredsRequest session = +getDefaultParams flags host store sStorage certCredsRequest session earlyData = (defaultParamsClient serverName BC.empty) - { clientSupported = def { supportedVersions = supportedVers, supportedCiphers = myCiphers } + { clientSupported = def { supportedVersions = supportedVers + , supportedCiphers = myCiphers + , supportedGroups = getGroups flags + } , clientWantSessionResume = session , clientUseServerNameIndication = not (NoSNI `elem` flags) , clientShared = def { sharedSessionManager = sessionRef sStorage @@ -78,6 +86,7 @@ getDefaultParams flags host store sStorage certCredsRequest session = then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed))) else (\_ -> return ()) } + , clientTLS13ZeroRttData = earlyData } where serverName = foldl f host flags @@ -116,13 +125,34 @@ getDefaultParams flags host store sStorage certCredsRequest session = | Tls11 `elem` flags = TLS11 | Ssl3 `elem` flags = SSL3 | Tls10 `elem` flags = TLS10 - | otherwise = TLS12 + | otherwise = TLS13ID18 supportedVers | NoVersionDowngrade `elem` flags = [tlsConnectVer] | otherwise = filter (<= tlsConnectVer) allVers - allVers = [SSL3, TLS10, TLS11, TLS12] + allVers = [SSL3, TLS10, TLS11, TLS12, TLS13ID18] validateCert = not (NoValidateCert `elem` flags) +getGroups flags = case getGroup of + Nothing -> [X448, X25519, P256] + Just gs -> case catMaybes $ map toG $ split ',' gs of + [] -> [X448, X25519, P256] + groups -> groups + where + getGroup = foldl f Nothing flags + where f _ (Group g) = Just g + f acc _ = acc + split _ "" = [] + split c s = case break (c==) s of + ("",r) -> split c (tail r) + (s',"") -> [s'] + (s',r) -> s' : split c (tail r) + toG "x25519" = Just X25519 + toG "x448" = Just X448 + toG "p256" = Just P256 + toG "p384" = Just P384 + toG "p521" = Just P521 + toG _ = Nothing + data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11 | Ssl3 | Tls10 | Tls11 | Tls12 | SNI String @@ -130,6 +160,7 @@ data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11 | Uri String | NoVersionDowngrade | UserAgent String + | Input String | Output String | Timeout String | BogusCipher String @@ -141,6 +172,7 @@ data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11 | ListCiphers | DebugSeed String | DebugPrintSeed + | Group String | Help deriving (Show,Eq) @@ -150,7 +182,9 @@ options = , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout" , Option [] ["io-debug"] (NoArg IODebug) "TLS IO debug output on stdout" , Option ['s'] ["session"] (NoArg Session) "try to resume a session" + , Option ['Z'] ["zerortt"] (ReqArg Input "inpfile") "input for TLS 1.3 0RTT data" , Option ['O'] ["output"] (ReqArg Output "stdout") "output " + , Option ['g'] ["group"] (ReqArg Group "group") "group" , Option ['t'] ["timeout"] (ReqArg Timeout "timeout") "timeout in milliseconds (2s by default)" , Option [] ["no-validation"] (NoArg NoValidateCert) "disable certificate validation" , Option [] ["client-cert"] (ReqArg ClientCert "cert-file:key-file") "add a client certificate to use with the server" @@ -184,13 +218,14 @@ runOn (sStorage, certStore) flags port hostname certCredRequest <- getCredRequest doTLS certCredRequest noSession when (Session `elem` flags) $ do + putStrLn "\nResuming the session..." session <- readIORef sStorage doTLS certCredRequest (Just session) where runBench isSend = runTLS (Debug `elem` flags) (IODebug `elem` flags) - (getDefaultParams flags hostname certStore sStorage Nothing noSession) hostname port $ \ctx -> do + (getDefaultParams flags hostname certStore sStorage Nothing noSession Nothing) hostname port $ \ctx -> do handshake ctx if isSend then loopSendData getBenchAmount ctx @@ -219,14 +254,18 @@ runOn (sStorage, certStore) flags port hostname ++ "\r\n\r\n") when (Verbose `elem` flags) (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "") out <- maybe (return stdout) (flip openFile AppendMode) getOutput + earlyData <- case getInput of + Nothing -> return Nothing + Just i -> Just <$> B.readFile i runTLS (Debug `elem` flags) (IODebug `elem` flags) - (getDefaultParams flags hostname certStore sStorage certCredRequest sess) hostname port $ \ctx -> do + (getDefaultParams flags hostname certStore sStorage certCredRequest sess earlyData) hostname port $ \ctx -> do handshake ctx when (Verbose `elem` flags) $ printHandshakeInfo ctx sendData ctx $ query loopRecv out ctx bye ctx + when (isJust getOutput) $ hClose out return () when (isJust getOutput) $ hClose out loopRecv out ctx = do @@ -259,6 +298,9 @@ runOn (sStorage, certStore) flags port hostname mUserAgent = foldl f Nothing flags where f _ (UserAgent ua) = Just ua f acc _ = acc + getInput = foldl f Nothing flags + where f _ (Input i) = Just i + f acc _ = acc getOutput = foldl f Nothing flags where f _ (Output o) = Just o f acc _ = acc diff --git a/debug/src/SimpleServer.hs b/debug/src/SimpleServer.hs index e8d5ac4fb..2b85c2e8a 100644 --- a/debug/src/SimpleServer.hs +++ b/debug/src/SimpleServer.hs @@ -84,6 +84,7 @@ getDefaultParams flags store sStorage cred _session = do , serverHooks = def , serverSupported = def { supportedVersions = supportedVers , supportedCiphers = myCiphers + , supportedGroups = [X25519, P256] , supportedClientInitiatedRenegotiation = allowRenegotiation } , serverDebug = def { debugSeed = foldl getDebugSeed Nothing flags , debugPrintSeed = if DebugPrintSeed `elem` flags @@ -129,11 +130,11 @@ getDefaultParams flags store sStorage cred _session = do | Tls11 `elem` flags = TLS11 | Ssl3 `elem` flags = SSL3 | Tls10 `elem` flags = TLS10 - | otherwise = TLS12 + | otherwise = TLS13ID18 supportedVers | NoVersionDowngrade `elem` flags = [tlsConnectVer] | otherwise = filter (<= tlsConnectVer) allVers - allVers = [SSL3, TLS10, TLS11, TLS12] + allVers = [SSL3, TLS10, TLS11, TLS12, TLS13ID18] validateCert = not (NoValidateCert `elem` flags) allowRenegotiation = AllowRenegotiation `elem` flags