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 2675b8a59..737206988 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 @@ -95,7 +97,7 @@ data Context = Context , ctxState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. - , ctxEstablished_ :: IORef Bool -- ^ has the handshake been done and been successful. + , ctxEstablished_ :: IORef Established -- ^ has the handshake been done and been successful. , ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability. , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. -- the flag will be set to false regardless of its initial value @@ -110,8 +112,15 @@ data Context = Context , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state) , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet. -- it is usually nested in a write or read lock. + , ctxPendingActions :: MVar [Bytes -> IO ()] } +data Established = NotEstablished + | EarlyDataAllowed + | EarlyDataNotAllowed + | Established + deriving (Eq, Show) + updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx f = do x <- readIORef (ctxMeasurement ctx) @@ -159,7 +168,7 @@ ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True -ctxEstablished :: Context -> IO Bool +ctxEstablished :: Context -> IO Established ctxEstablished ctx = readIORef $ ctxEstablished_ ctx ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a @@ -168,7 +177,7 @@ ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO () contextModifyHooks ctx f = modifyIORef (ctxHooks ctx) f -setEstablished :: Context -> Bool -> IO () +setEstablished :: Context -> Established -> IO () setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v withLog :: Context -> (Logging -> IO ()) -> IO () @@ -205,8 +214,11 @@ getHState ctx = liftIO $ readMVar (ctxHandshake ctx) runTxState :: Context -> RecordM a -> IO (Either TLSError a) runTxState ctx f = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) + let ver' + | ver >= TLS13ID18 = TLS10 + | otherwise = ver modifyMVar (ctxTxState ctx) $ \st -> - case runRecordM f ver st of + case runRecordM f ver' st of Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) @@ -232,3 +244,10 @@ withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f withStateLock :: Context -> IO a -> IO a withStateLock ctx f = withMVar (ctxLockState ctx) (const f) + +tls13orLater :: MonadIO m => Context -> m Bool +tls13orLater ctx = do + ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS10 -- fixme + return $ case ev of + Left _ -> False + Right v -> v >= TLS13ID18 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 f81238cb1..967c06805 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.Monoid diff --git a/core/Network/TLS/Extension.hs b/core/Network/TLS/Extension.hs index 1e5facc15..0e364f964 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 Bytes Word32 deriving (Eq, Show) + +data PreSharedKey = + PreSharedKeyClientHello [PskIdentity] [Bytes] + | 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 f8af77911..427d4ac7a 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 () @@ -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 Bytes diff --git a/core/Network/TLS/Handshake/Common13.hs b/core/Network/TLS/Handshake/Common13.hs new file mode 100644 index 000000000..7687f619d --- /dev/null +++ b/core/Network/TLS/Handshake/Common13.hs @@ -0,0 +1,231 @@ +{-# 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 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 -> Bytes -> IO Handshake13 +makeFinished ctx usedHash baseKey = do + transcript <- getHandshakeContextHash ctx + return $ Finished13 $ makeVerifyData usedHash baseKey transcript + +makeVerifyData :: Hash -> Bytes -> Bytes -> Bytes +makeVerifyData usedHash baseKey hashValue = hmac usedHash finishedKey hashValue + where + hashSize = hashDigestSize usedHash + finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize + +---------------------------------------------------------------- + +makeServerKeyShare :: Context -> KeyShareEntry -> IO (Bytes, 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 Bytes +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 :: Bytes +serverContextString = "TLS 1.3, server CertificateVerify" + +clientContextString :: Bytes +clientContextString = "TLS 1.3, client CertificateVerify" + +makeServerCertVerify :: Context -> HashAndSignatureAlgorithm -> PrivKey -> Bytes -> IO Handshake13 +makeServerCertVerify ctx hs privKey hashValue = + CertVerify13 hs <$> sign ctx hs privKey target + where + target = makeTarget serverContextString hashValue + +makeClientCertVerify :: Context -> HashAndSignatureAlgorithm -> PrivKey -> Bytes -> IO Handshake13 +makeClientCertVerify ctx hs privKey hashValue = + CertVerify13 hs <$> sign ctx hs privKey target + where + target = makeTarget clientContextString hashValue + +checkServerCertVerify :: HashAndSignatureAlgorithm -> Bytes -> PubKey -> Bytes -> 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 :: Bytes -> Bytes -> Bytes +makeTarget contextString hashValue = runPut $ do + putBytes $ B.pack $ replicate 64 32 + putBytes contextString + putWord8 0 + putBytes hashValue + +sign :: Context -> HashAndSignatureAlgorithm -> PrivKey -> Bytes -> IO Bytes +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 -> Bytes +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 :: Bytes -> 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 -> Bytes -> Hash -> Int -> Maybe Bytes -> IO Bytes +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 :: Bytes -> Bytes -> Bytes +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 e009efddd..c1a701218 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 b1ba59010..d305c1c1b 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 @@ -76,7 +88,7 @@ data HandshakeState = HandshakeState , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate) , hstServerECDHParams :: !(Maybe ServerECDHParams) - , hstECDHPrivate :: !(Maybe GroupPrivate) + , hstGroupPrivate :: !(Maybe GroupPrivate) , hstHandshakeDigest :: !(Either [Bytes] HashCtx) , hstHandshakeMessages :: [Bytes] , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received @@ -87,6 +99,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], @@ -114,7 +130,7 @@ newEmptyHandshake ver crand = HandshakeState , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing - , hstECDHPrivate = Nothing + , hstGroupPrivate = Nothing , hstHandshakeDigest = Left [] , hstHandshakeMessages = [] , hstClientCertRequest = Nothing @@ -125,6 +141,10 @@ newEmptyHandshake ver crand = HandshakeState , hstPendingRxState = Nothing , hstPendingCipher = Nothing , hstPendingCompression = nullCompression + , hstTLS13Group = Nothing + , hstTLS13HRR = False + , hstTLS13RTT0 = False + , hstTLS13HandshakeMsgs = [] } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState) @@ -144,29 +164,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 Bytes -> HandshakeM () +setTLS13MasterSecret msecret = modify (\hst -> hst { hstMasterSecret = msecret }) + +getTLS13MasterSecret :: HandshakeM (Maybe Bytes) +getTLS13MasterSecret = gets hstMasterSecret setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b }) @@ -201,6 +251,9 @@ addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = conten getHandshakeMessages :: HandshakeM [Bytes] getHandshakeMessages = gets (reverse . hstHandshakeMessages) +getHandshakeMessagesRev :: HandshakeM [Bytes] +getHandshakeMessagesRev = gets hstHandshakeMessages + updateHandshakeDigest :: Bytes -> 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..3fd883ca0 --- /dev/null +++ b/core/Network/TLS/Handshake/State13.hs @@ -0,0 +1,83 @@ +{-# 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 qualified Data.ByteString as B +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 +import Network.TLS.Struct + +setTxState :: Context -> Hash -> Cipher -> B.ByteString -> IO () +setTxState = setXState ctxTxState BulkEncrypt + +setRxState :: Context -> Hash -> Cipher -> B.ByteString -> IO () +setRxState = setXState ctxRxState BulkDecrypt + +setXState :: (Context -> MVar RecordState) -> BulkDirection + -> Context -> Hash -> Cipher -> B.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 B.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 -> [Bytes -> IO ()] -> IO () +setPendingActions ctx bss = + modifyMVar_ (ctxPendingActions ctx) (\_ -> return bss) + +popPendingAction :: Context -> IO (Bytes -> 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 cd4b1f45c..2939308ee 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 () @@ -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 -> Bytes -> 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 -> Bytes -> 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 04125f3e8..43c8a6e90 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 Bytes 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 -> Bytes -> Bytes -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..1b44df111 --- /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, Bytes) +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 cb875d915..a539d23d0 100644 --- a/core/Network/TLS/Parameters.hs +++ b/core/Network/TLS/Parameters.hs @@ -92,6 +92,7 @@ data ClientParams = ClientParams -- of 'supportedCiphers' with a suitable cipherlist. , clientSupported :: Supported , clientDebug :: DebugParams + , clientTLS13ZeroRttData :: Maybe Bytes } deriving (Show) defaultParamsClient :: HostName -> Bytes -> ClientParams @@ -104,6 +105,7 @@ defaultParamsClient serverName serverId = ClientParams , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams + , clientTLS13ZeroRttData = Nothing } data ServerParams = ServerParams @@ -197,7 +199,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..953704f1e --- /dev/null +++ b/core/Network/TLS/Record/Disengage13.hs @@ -0,0 +1,77 @@ +{-# 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 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 :: Bytes -> RecordState -> RecordM Bytes +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 Bytes + 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..ab364e36b --- /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, Bytes) +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 -> Bytes -> Bytes +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..f8353b582 --- /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 Network.TLS.Struct (Bytes) +import Network.TLS.Struct13 +import Network.TLS.Record.Types (Header(..)) + +-- | Represent a TLS record. +data Record13 = Record13 !ContentType Bytes deriving (Show,Eq) + +-- | turn a header and a fragment into a record +rawToRecord13 :: Header -> Bytes -> 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..424a2e152 --- /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 Bytes +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 9aef37f6b..abe2e3c34 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) @@ -74,6 +75,7 @@ data TLSState = TLSState , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, Bytes)) , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol + , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType13, Bytes)) , stClientALPNSuggest :: Maybe [B.ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] @@ -106,9 +108,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 @@ -135,6 +138,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 @@ -150,6 +154,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 3af600046..09cf21003 100644 --- a/core/Network/TLS/Struct.hs +++ b/core/Network/TLS/Struct.hs @@ -207,6 +207,7 @@ data AlertLevel = data AlertDescription = CloseNotify + | EndOfEarlyData | UnexpectedMessage | BadRecordMac | DecryptionFailed -- ^ deprecated alert, should never be sent by compliant implementation @@ -230,11 +231,14 @@ data AlertDescription = | InappropriateFallback -- RFC7507 | UserCanceled | NoRenegotiation + | MissingExtension | UnsupportedExtension | CertificateUnobtainable | UnrecognizedName | BadCertificateStatusResponse | BadCertificateHashValue + | UnknownPskIdentity + | CertificateRequired deriving (Show,Eq) data HandshakeType = @@ -248,6 +252,7 @@ data HandshakeType = | HandshakeType_CertVerify | HandshakeType_ClientKeyXchg | HandshakeType_Finished + | HandshakeType_HelloRetryRequest deriving (Show,Eq) newtype BigNum = BigNum Bytes @@ -320,6 +325,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 @@ -339,6 +346,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) @@ -346,6 +355,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 @@ -353,6 +364,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 @@ -400,20 +413,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 @@ -433,6 +448,7 @@ instance TypeValuable AlertLevel where instance TypeValuable AlertDescription where valOfType CloseNotify = 0 + valOfType EndOfEarlyData = 1 valOfType UnexpectedMessage = 10 valOfType BadRecordMac = 20 valOfType DecryptionFailed = 21 @@ -456,13 +472,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 @@ -486,11 +506,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..14ca8040a --- /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 Bytes [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 0c35a1718..dea229955 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 @@ -109,6 +111,9 @@ getWord24 = do getWord32 :: Get Word32 getWord32 = getWord32be +getWord64 :: Get Word64 +getWord64 = getWord64be + getOpaque8 :: Get Bytes getOpaque8 = getWord8 >>= getBytes . fromIntegral @@ -145,6 +150,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