diff --git a/core/Network/TLS/Context.hs b/core/Network/TLS/Context.hs index e5da252af..e18e15a9e 100644 --- a/core/Network/TLS/Context.hs +++ b/core/Network/TLS/Context.hs @@ -131,7 +131,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. @@ -141,6 +141,7 @@ contextNew backend params = liftIO $ do tx <- newMVar newRecordState rx <- newMVar newRecordState hs <- newMVar Nothing + as <- newMVar [] lockWrite <- newMVar () lockRead <- newMVar () lockState <- newMVar () @@ -164,6 +165,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 e092c3e33..e5b98dd6c 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 @@ -83,6 +84,7 @@ data Information = Information , infoMasterSecret :: Maybe ByteString , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom + , infoIsEarlyDataAccepted :: Bool } deriving (Show,Eq) -- | A TLS Context keep tls specific state, parameters and backend information. @@ -93,7 +95,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 @@ -108,8 +110,15 @@ data Context = Context , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state) , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet. -- it is usually nested in a write or read lock. + , ctxPendingActions :: MVar [ByteString -> IO ()] } +data Established = NotEstablished + | EarlyDataAllowed Int + | EarlyDataNotAllowed + | Established + deriving (Eq, Show) + updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx f = do x <- readIORef (ctxMeasurement ctx) @@ -135,8 +144,11 @@ contextGetInformation ctx = do hstServerRandom st) Nothing -> (Nothing, Nothing, Nothing) (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \st -> (stCipher st, stCompression st) + let accepted = case hstate of + Just st -> hstTLS13RTT0Status st == RTT0Accepted + Nothing -> False case (ver, cipher) of - (Just v, Just c) -> return $ Just $ Information v c comp ms cr sr + (Just v, Just c) -> return $ Just $ Information v c comp ms cr sr accepted _ -> return Nothing contextSend :: Context -> ByteString -> IO () @@ -157,7 +169,7 @@ ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True -ctxEstablished :: Context -> IO Bool +ctxEstablished :: Context -> IO Established ctxEstablished ctx = readIORef $ ctxEstablished_ ctx ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a @@ -166,7 +178,7 @@ ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO () contextModifyHooks ctx f = modifyIORef (ctxHooks ctx) f -setEstablished :: Context -> Bool -> IO () +setEstablished :: Context -> Established -> IO () setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v withLog :: Context -> (Logging -> IO ()) -> IO () diff --git a/core/Network/TLS/Handshake.hs b/core/Network/TLS/Handshake.hs index c5a8db8d2..4c4b88a8f 100644 --- a/core/Network/TLS/Handshake.hs +++ b/core/Network/TLS/Handshake.hs @@ -42,7 +42,7 @@ handshakeWith ctx hs = handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception - setEstablished ctx False + setEstablished ctx NotEstablished sendPacket ctx (errorToAlert tlserror) `catch` ignoreIOErr handshakeFailed tlserror where diff --git a/core/Network/TLS/Handshake/Common.hs b/core/Network/TLS/Handshake/Common.hs index b0fa99a51..eefb5f8ed 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 @@ -24,7 +25,7 @@ import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct import Network.TLS.IO -import Network.TLS.State hiding (getNegotiatedProtocol) +import Network.TLS.State import Network.TLS.Handshake.Process import Network.TLS.Handshake.State import Network.TLS.Record.State @@ -73,7 +74,7 @@ handshakeTerminate ctx = do } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. - setEstablished ctx True + setEstablished ctx Established return () sendChangeCipherAndFinish :: Context @@ -126,6 +127,7 @@ getSessionData ctx = do sni <- usingState_ ctx getClientSNI mms <- usingHState ctx (gets hstMasterSecret) tx <- liftIO $ readMVar (ctxTxState ctx) + alpn <- usingState_ ctx getNegotiatedProtocol case mms of Nothing -> return Nothing Just ms -> return $ Just SessionData @@ -134,6 +136,10 @@ getSessionData ctx = do , sessionCompression = compressionID $ stCompression tx , sessionClientSNI = sni , sessionSecret = ms + , sessionGroup = Nothing + , sessionTicketInfo = Nothing + , sessionALPN = alpn + , sessionMaxEarlyDataSize = 0 } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString diff --git a/core/Network/TLS/Handshake/Server.hs b/core/Network/TLS/Handshake/Server.hs index e00c79915..47c0c8a8e 100644 --- a/core/Network/TLS/Handshake/Server.hs +++ b/core/Network/TLS/Handshake/Server.hs @@ -82,7 +82,7 @@ handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientS 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) diff --git a/core/Network/TLS/Handshake/Signature.hs b/core/Network/TLS/Handshake/Signature.hs index 6e3eb84a5..39175d33f 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 (_, SignatureRSApssRSAeSHA256) = True diff --git a/core/Network/TLS/Handshake/State.hs b/core/Network/TLS/Handshake/State.hs index 3c66f6ebd..2ddecdf51 100644 --- a/core/Network/TLS/Handshake/State.hs +++ b/core/Network/TLS/Handshake/State.hs @@ -10,6 +10,8 @@ -- module Network.TLS.Handshake.State ( HandshakeState(..) + , RTT0Status(..) + , TLS13Secret(..) , ClientCertRequestData , HandshakeM , newEmptyHandshake @@ -40,6 +42,7 @@ module Network.TLS.Handshake.State , addHandshakeMessage , updateHandshakeDigest , getHandshakeMessages + , getHandshakeMessagesRev , getHandshakeDigest -- * master secret , setMasterSecret @@ -47,10 +50,19 @@ module Network.TLS.Handshake.State -- * misc accessor , getPendingCipher , setServerHelloParameters + , setTLS13Group + , getTLS13Group + , setTLS13RTT0Status + , getTLS13RTT0Status + , setTLS13HandshakeMsgs + , getTLS13HandshakeMsgs + , setTLS13Secret + , getTLS13Secret ) 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 @@ -62,6 +74,11 @@ import Control.Monad.State.Strict import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess) +data TLS13Secret = NoSecret + | EarlySecret ByteString + | ResuptionSecret ByteString + deriving (Eq, Show) + data HandshakeKeyState = HandshakeKeyState { hksRemotePublicKey :: !(Maybe PubKey) , hksLocalPrivateKey :: !(Maybe PrivKey) @@ -87,6 +104,10 @@ data HandshakeState = HandshakeState , hstPendingRxState :: Maybe RecordState , hstPendingCipher :: Maybe Cipher , hstPendingCompression :: Compression + , hstTLS13Group :: Maybe Group + , hstTLS13RTT0Status :: !RTT0Status + , hstTLS13HandshakeMsgs :: [Handshake13] + , hstTLS13Secret :: TLS13Secret } deriving (Show) type ClientCertRequestData = ([CertificateType], @@ -125,6 +146,10 @@ newEmptyHandshake ver crand = HandshakeState , hstPendingRxState = Nothing , hstPendingCipher = Nothing , hstPendingCompression = nullCompression + , hstTLS13Group = Nothing + , hstTLS13RTT0Status = RTT0None + , hstTLS13HandshakeMsgs = [] + , hstTLS13Secret = NoSecret } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState) @@ -144,17 +169,20 @@ 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 @@ -162,12 +190,39 @@ getDHPrivate = fromJust "server DH private" <$> gets hstDHPrivate 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 + +data RTT0Status = RTT0None + | RTT0Sent + | RTT0Accepted + | RTT0Rejected + deriving (Show,Eq) + +setTLS13RTT0Status :: RTT0Status -> HandshakeM () +setTLS13RTT0Status s = modify (\hst -> hst { hstTLS13RTT0Status = s }) + +getTLS13RTT0Status :: HandshakeM RTT0Status +getTLS13RTT0Status = gets hstTLS13RTT0Status + +setTLS13HandshakeMsgs :: [Handshake13] -> HandshakeM () +setTLS13HandshakeMsgs hmsgs = modify (\hst -> hst { hstTLS13HandshakeMsgs = hmsgs }) + +getTLS13HandshakeMsgs :: HandshakeM [Handshake13] +getTLS13HandshakeMsgs = gets hstTLS13HandshakeMsgs + +setTLS13Secret :: TLS13Secret -> HandshakeM () +setTLS13Secret secret = modify (\hst -> hst { hstTLS13Secret = secret }) + +getTLS13Secret :: HandshakeM TLS13Secret +getTLS13Secret = gets hstTLS13Secret + setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b }) @@ -201,6 +256,9 @@ addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = conten getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) +getHandshakeMessagesRev :: HandshakeM [ByteString] +getHandshakeMessagesRev = gets hstHandshakeMessages + updateHandshakeDigest :: ByteString -> HandshakeM () updateHandshakeDigest content = modify $ \hs -> hs { hstHandshakeDigest = case hstHandshakeDigest hs of diff --git a/core/Network/TLS/IO.hs b/core/Network/TLS/IO.hs index 6bd51f6c2..9612bd758 100644 --- a/core/Network/TLS/IO.hs +++ b/core/Network/TLS/IO.hs @@ -30,7 +30,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 diff --git a/core/Network/TLS/Parameters.hs b/core/Network/TLS/Parameters.hs index 1c1b52788..f9b21946b 100644 --- a/core/Network/TLS/Parameters.hs +++ b/core/Network/TLS/Parameters.hs @@ -89,6 +89,10 @@ data ClientParams = ClientParams -- of 'supportedCiphers' with a suitable cipherlist. , clientSupported :: Supported , clientDebug :: DebugParams + -- ^ Client tries to send this early data in TLS 1.3 if possible. + -- If not accepted by the server, it is application's responsibility + -- to re-sent it. + , clientEarlyData :: Maybe ByteString } deriving (Show) defaultParamsClient :: HostName -> ByteString -> ClientParams @@ -101,6 +105,7 @@ defaultParamsClient serverName serverId = ClientParams , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams + , clientEarlyData = Nothing } data ServerParams = ServerParams @@ -125,6 +130,9 @@ data ServerParams = ServerParams , serverHooks :: ServerHooks , serverSupported :: Supported , serverDebug :: DebugParams + -- ^ Server accepts this size of early data in TLS 1.3. + -- 0 (or lower) means that the server does not accept early data. + , serverEarlyDataSize :: Int } deriving (Show) defaultParamsServer :: ServerParams @@ -136,6 +144,7 @@ defaultParamsServer = ServerParams , serverShared = def , serverSupported = def , serverDebug = defaultDebugParams + , serverEarlyDataSize = 0 } instance Default ServerParams where @@ -201,7 +210,10 @@ defaultSupported = Supported { supportedVersions = [TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression] - , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA) + , supportedHashSignatures = [ (HashIntrinsic, SignatureRSApssRSAeSHA256) + , (HashIntrinsic, SignatureRSApssRSAeSHA384) + , (HashIntrinsic, SignatureRSApssRSAeSHA512) + , (Struct.HashSHA512, SignatureRSA) , (Struct.HashSHA512, SignatureECDSA) , (Struct.HashSHA384, SignatureRSA) , (Struct.HashSHA384, SignatureECDSA) diff --git a/core/Network/TLS/Session.hs b/core/Network/TLS/Session.hs index fd92eae46..24e38d943 100644 --- a/core/Network/TLS/Session.hs +++ b/core/Network/TLS/Session.hs @@ -15,16 +15,19 @@ import Network.TLS.Types -- | A session manager data SessionManager = SessionManager { -- | used on server side to decide whether to resume a client session. - sessionResume :: SessionID -> IO (Maybe SessionData) + sessionResume :: SessionID -> IO (Maybe SessionData) + -- | used on server side to decide whether to resume a client session for TLS 1.3 0RTT. For a given 'SessionID', the implementation must return its 'SessionData' only once and must not return the same 'SessionData' after the call. + , sessionResumeOnlyOnce :: SessionID -> IO (Maybe SessionData) -- | used when a session is established. - , sessionEstablish :: SessionID -> SessionData -> IO () + , sessionEstablish :: SessionID -> SessionData -> IO () -- | used when a session is invalidated. - , sessionInvalidate :: SessionID -> IO () + , sessionInvalidate :: SessionID -> IO () } noSessionManager :: SessionManager noSessionManager = SessionManager - { sessionResume = \_ -> return Nothing - , sessionEstablish = \_ _ -> return () - , sessionInvalidate = \_ -> return () + { sessionResume = \_ -> return Nothing + , sessionResumeOnlyOnce = \_ -> return Nothing + , sessionEstablish = \_ _ -> return () + , sessionInvalidate = \_ -> return () } diff --git a/core/Network/TLS/State.hs b/core/Network/TLS/State.hs index cfa413251..b72edd450 100644 --- a/core/Network/TLS/State.hs +++ b/core/Network/TLS/State.hs @@ -46,6 +46,16 @@ module Network.TLS.State , getSession , isSessionResuming , isClientContext + , setExporterMasterSecret + , getExporterMasterSecret + , setTLS13KeyShare + , getTLS13KeyShare + , setTLS13PreSharedKey + , getTLS13PreSharedKey + , setTLS13HRR + , getTLS13HRR + , setTLS13Cookie + , getTLS13Cookie -- * random , genRandom , withRNG @@ -53,6 +63,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 +85,7 @@ data TLSState = TLSState , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol + , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType13, ByteString)) , stClientALPNSuggest :: Maybe [B.ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] @@ -82,6 +94,11 @@ data TLSState = TLSState , stRandomGen :: StateRNG , stVersion :: Maybe Version , stClientContext :: Role + , stTLS13KeyShare :: Maybe KeyShare + , stTLS13PreSharedKey :: Maybe PreSharedKey + , stTLS13HRR :: !Bool + , stTLS13Cookie :: Maybe Cookie + , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3 } newtype TLSSt a = TLSSt { runTLSSt :: ErrT TLSError (State TLSState) a } @@ -106,15 +123,21 @@ 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 , stRandomGen = rng , stVersion = Nothing , stClientContext = clientContext + , stTLS13KeyShare = Nothing + , stTLS13PreSharedKey = Nothing + , stTLS13HRR = False + , stTLS13Cookie = Nothing + , stExporterMasterSecret = Nothing } updateVerifiedData :: Role -> ByteString -> TLSSt () @@ -236,3 +259,33 @@ withRNG f = do let (a,rng') = withTLSRNG (stRandomGen st) f put (st { stRandomGen = rng' }) return a + +setExporterMasterSecret :: ByteString -> TLSSt () +setExporterMasterSecret key = modify (\st -> st { stExporterMasterSecret = Just key }) + +getExporterMasterSecret :: TLSSt (Maybe ByteString) +getExporterMasterSecret = gets stExporterMasterSecret + +setTLS13KeyShare :: Maybe KeyShare -> TLSSt () +setTLS13KeyShare mks = modify (\st -> st { stTLS13KeyShare = mks }) + +getTLS13KeyShare :: TLSSt (Maybe KeyShare) +getTLS13KeyShare = gets stTLS13KeyShare + +setTLS13PreSharedKey :: Maybe PreSharedKey -> TLSSt () +setTLS13PreSharedKey mpsk = modify (\st -> st { stTLS13PreSharedKey = mpsk }) + +getTLS13PreSharedKey :: TLSSt (Maybe PreSharedKey) +getTLS13PreSharedKey = gets stTLS13PreSharedKey + +setTLS13HRR :: Bool -> TLSSt () +setTLS13HRR b = modify (\st -> st { stTLS13HRR = b }) + +getTLS13HRR :: TLSSt Bool +getTLS13HRR = gets stTLS13HRR + +setTLS13Cookie :: Cookie -> TLSSt () +setTLS13Cookie cookie = modify (\st -> st { stTLS13Cookie = Just cookie }) + +getTLS13Cookie :: TLSSt (Maybe Cookie) +getTLS13Cookie = gets stTLS13Cookie diff --git a/core/Network/TLS/Struct13.hs b/core/Network/TLS/Struct13.hs new file mode 100644 index 000000000..507b6fcef --- /dev/null +++ b/core/Network/TLS/Struct13.hs @@ -0,0 +1,111 @@ +module Network.TLS.Struct13 where + +import Data.X509 (CertificateChain) +import Network.TLS.Struct +import Network.TLS.Types +import Network.TLS.Imports + +data Packet13 = + Handshake13 [Handshake13] + | Alert13 [(AlertLevel, AlertDescription)] + | ChangeCipherSpec13 + | AppData13 ByteString + deriving (Show,Eq) + +newtype CertificateEntry13 = CertificateEntry13 [ExtensionRaw] + deriving (Show,Eq) + +data Handshake13 = + ClientHello13 !Version !ClientRandom !Session ![CipherID] [ExtensionRaw] + | ServerHello13 !ServerRandom !Session !CipherID [ExtensionRaw] + | NewSessionTicket13 Word32 Word32 ByteString ByteString [ExtensionRaw] -- fixme + | EndOfEarlyData13 + | 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_EndOfEarlyData13 + | HandshakeType_NewSessionTicket13 + | 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 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData13 +typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket13 +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_EndOfEarlyData13 = 5 + 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 5 = Just HandshakeType_EndOfEarlyData13 + 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_ChangeCipherSpec + | ContentType_Alert + | ContentType_Handshake + | ContentType_AppData + deriving (Eq, Show) + + +instance TypeValuable ContentType where + valOfType ContentType_ChangeCipherSpec = 20 + valOfType ContentType_Alert = 21 + valOfType ContentType_Handshake = 22 + valOfType ContentType_AppData = 23 + + valToType 20 = Just ContentType_ChangeCipherSpec + valToType 21 = Just ContentType_Alert + valToType 22 = Just ContentType_Handshake + valToType 23 = Just ContentType_AppData + valToType _ = Nothing + +contentType :: Packet13 -> ContentType +contentType ChangeCipherSpec13 = ContentType_ChangeCipherSpec +contentType (Handshake13 _) = ContentType_Handshake +contentType (Alert13 _) = ContentType_Alert +contentType (AppData13 _) = ContentType_AppData + +protoToContent :: ProtocolType -> ContentType +protoToContent ProtocolType_ChangeCipherSpec = ContentType_ChangeCipherSpec +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 22f2f2f61..25617fbc4 100644 --- a/core/Network/TLS/Types.hs +++ b/core/Network/TLS/Types.hs @@ -9,16 +9,24 @@ module Network.TLS.Types ( Version(..) , SessionID , SessionData(..) + , TLS13TicketInfo(..) , CipherID , CompressionID , Role(..) , invertRole , Direction(..) +-- , HostName + , Second + , Millisecond ) where +import Data.IORef (IORef) import Network.TLS.Imports +import Network.TLS.Crypto.Types (Group) type HostName = String +type Second = Word32 +type Millisecond = Word64 -- | Versions known to TLS -- @@ -35,8 +43,27 @@ data SessionData = SessionData , sessionCompression :: CompressionID , sessionClientSNI :: Maybe HostName , sessionSecret :: ByteString + , sessionGroup :: Maybe Group + , sessionTicketInfo :: Maybe TLS13TicketInfo + , sessionALPN :: Maybe ByteString + , sessionMaxEarlyDataSize :: Int } deriving (Show,Eq) +data TLS13TicketInfo = TLS13TicketInfo + { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds + , ageAdd :: Second -- NewSessionTicket.ticket_age_add + , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime + , estimatedRTT :: IORef (Maybe Millisecond) + } deriving (Eq) + +instance Show TLS13TicketInfo where + showsPrec d s = showParen (d > 10) $ + showString "TLS13TicketInfo { " + . showString "lifetime = " . shows (lifetime s) + . showString ", ageAdd = " . shows (ageAdd s) + . showString ", txrxTime = " . shows (txrxTime s) + . showString " }" + -- | Cipher identification type CipherID = Word16 diff --git a/core/Tests/Connection.hs b/core/Tests/Connection.hs index f7b54a6e9..c2f248d92 100644 --- a/core/Tests/Connection.hs +++ b/core/Tests/Connection.hs @@ -187,9 +187,10 @@ arbitraryRSACredentialWithUsage usageFlags = do -- a Real concurrent session manager would use an MVar and have multiples items. oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager oneSessionManager ref = SessionManager - { sessionResume = \myId -> (>>= maybeResume myId) <$> readIORef ref - , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) - , sessionInvalidate = \_ -> return () + { sessionResume = \myId -> (>>= maybeResume myId) <$> readIORef ref + , sessionResumeOnlyOnce = \myId -> (>>= maybeResume myId) <$> readIORef ref + , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) + , sessionInvalidate = \_ -> return () } where maybeResume myId (sid, sdata) diff --git a/core/tls.cabal b/core/tls.cabal index ab32b8e2a..02b8a8752 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -71,6 +71,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 diff --git a/debug/src/SimpleClient.hs b/debug/src/SimpleClient.hs index 306c06af8..43e529c60 100644 --- a/debug/src/SimpleClient.hs +++ b/debug/src/SimpleClient.hs @@ -54,9 +54,10 @@ runTLS debug ioDebug params hostname portNumber f = do | otherwise = logging sessionRef ref = SessionManager - { sessionEstablish = \sid sdata -> writeIORef ref (sid,sdata) - , sessionResume = \sid -> readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing - , sessionInvalidate = \_ -> return () + { sessionEstablish = \sid sdata -> writeIORef ref (sid,sdata) + , sessionResume = \sid -> readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing + , sessionResumeOnlyOnce = \sid -> readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing + , sessionInvalidate = \_ -> return () } getDefaultParams flags host store sStorage certCredsRequest session = diff --git a/debug/src/Stunnel.hs b/debug/src/Stunnel.hs index bf1ecf430..cbc54d04a 100644 --- a/debug/src/Stunnel.hs +++ b/debug/src/Stunnel.hs @@ -72,9 +72,10 @@ tlsserver srchandle dsthandle = do newtype MemSessionManager = MemSessionManager (MVar [(SessionID, SessionData)]) memSessionManager (MemSessionManager mvar) = SessionManager - { sessionEstablish = \sid sdata -> modifyMVar_ mvar (\l -> return $ (sid,sdata) : l) - , sessionResume = \sid -> withMVar mvar (return . lookup sid) - , sessionInvalidate = \_ -> return () + { sessionEstablish = \sid sdata -> modifyMVar_ mvar (\l -> return $ (sid,sdata) : l) + , sessionResume = \sid -> withMVar mvar (return . lookup sid) + , sessionResumeOnlyOnce = \sid -> withMVar mvar (return . lookup sid) + , sessionInvalidate = \_ -> return () } clientProcess dhParamsFile creds handle dsthandle dbg sessionStorage _ = do diff --git a/session/Network/TLS/SessionManager.hs b/session/Network/TLS/SessionManager.hs index 0b67a76b3..bb9a3de4b 100644 --- a/session/Network/TLS/SessionManager.hs +++ b/session/Network/TLS/SessionManager.hs @@ -69,9 +69,11 @@ newSessionManager conf = do , reaperDelay = pruningDelay conf * 1000000 } return SessionManager { - sessionResume = resume reaper MultipleUse - , sessionEstablish = establish reaper lifetime - , sessionInvalidate = invalidate reaper + sessionResume = resume reaper MultipleUse + , sessionResumeOnlyOnce = resume reaper SingleUse + , sessionEstablish = establish reaper lifetime + , sessionInvalidate = invalidate reaper + } cons :: Int -> Item -> DB -> DB