{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.TLS.Handshake.Server.TLS13 (
    recvClientSecondFlight13,
    requestCertificateServer,
    keyUpdate,
    updateKey,
    KeyUpdateRequest (..),
) where

import Control.Exception
import Control.Monad.State.Strict
import qualified Data.ByteString.Char8 as C8
import Data.IORef

import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Common hiding (expectFinished)
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.Handshake.TranscriptHash
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.KeySchedule
import Network.TLS.Parameters
import Network.TLS.Session
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.Util
import Network.TLS.X509

----------------------------------------------------------------

recvClientSecondFlight13
    :: ServerParams
    -> Context
    -> ( SecretTriple ApplicationSecret
       , ClientTrafficSecret HandshakeSecret
       , Bool
       , Bool
       )
    -> ClientHello
    -> IO ()
recvClientSecondFlight13 :: ServerParams
-> Context
-> (SecretTriple ApplicationSecret,
    ClientTrafficSecret HandshakeSecret, Bool, Bool)
-> ClientHello
-> IO ()
recvClientSecondFlight13 ServerParams
sparams Context
ctx (SecretTriple ApplicationSecret
appKey, ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, Bool
authenticated, Bool
rtt0OK) CH{[CompressionID]
[CipherId]
[ExtensionRaw]
Version
Session
ClientRandom
chVersion :: Version
chRandom :: ClientRandom
chSession :: Session
chCiphers :: [CipherId]
chComps :: [CompressionID]
chExtensions :: [ExtensionRaw]
chVersion :: ClientHello -> Version
chRandom :: ClientHello -> ClientRandom
chSession :: ClientHello -> Session
chCiphers :: ClientHello -> [CipherId]
chComps :: ClientHello -> [CompressionID]
chExtensions :: ClientHello -> [ExtensionRaw]
..} = do
    Millisecond
sfSentTime <- IO Millisecond
getCurrentTimeFromBase
    let expectFinished' :: TranscriptHash -> Handshake13 -> RecvHandshake13M IO ()
expectFinished' =
            ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> TranscriptHash
-> Handshake13
-> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> TranscriptHash
-> Handshake13
-> m ()
expectFinished ServerParams
sparams Context
ctx [ExtensionRaw]
chExtensions SecretTriple ApplicationSecret
appKey ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Millisecond
sfSentTime
    if Bool -> Bool
not Bool
authenticated Bool -> Bool -> Bool
&& ServerParams -> Bool
serverWantClientCert ServerParams
sparams
        then RecvHandshake13M IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 (RecvHandshake13M IO () -> IO ())
-> RecvHandshake13M IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Context
-> (Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx ((Handshake13 -> RecvHandshake13M IO ()) -> RecvHandshake13M IO ())
-> (Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall a b. (a -> b) -> a -> b
$ ServerParams -> Context -> Handshake13 -> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> Handshake13 -> m ()
expectCertificate ServerParams
sparams Context
ctx
            Context
-> String
-> (TranscriptHash -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> String
-> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx String
"CertVerify" (ServerParams
-> Context
-> TranscriptHash
-> Handshake13
-> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx)
            Context
-> String
-> (TranscriptHash -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> String
-> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx String
"Finished" TranscriptHash -> Handshake13 -> RecvHandshake13M IO ()
expectFinished'
            Context -> RecvHandshake13M IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
        else
            if Bool
rtt0OK Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)
                then
                    Context -> [PendingRecvAction] -> IO ()
setPendingRecvActions
                        Context
ctx
                        [ Bool -> Bool -> (Handshake13 -> IO ()) -> PendingRecvAction
PendingRecvAction Bool
True Bool
True ((Handshake13 -> IO ()) -> PendingRecvAction)
-> (Handshake13 -> IO ()) -> PendingRecvAction
forall a b. (a -> b) -> a -> b
$ Context
-> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()
expectEndOfEarlyData Context
ctx ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
                        , Bool
-> (TranscriptHash -> Handshake13 -> IO ()) -> PendingRecvAction
PendingRecvActionHash Bool
True ((TranscriptHash -> Handshake13 -> IO ()) -> PendingRecvAction)
-> (TranscriptHash -> Handshake13 -> IO ()) -> PendingRecvAction
forall a b. (a -> b) -> a -> b
$
                            ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> TranscriptHash
-> Handshake13
-> IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> TranscriptHash
-> Handshake13
-> m ()
expectFinished ServerParams
sparams Context
ctx [ExtensionRaw]
chExtensions SecretTriple ApplicationSecret
appKey ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Millisecond
sfSentTime
                        ]
                else RecvHandshake13M IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 (RecvHandshake13M IO () -> IO ())
-> RecvHandshake13M IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Context
-> String
-> (TranscriptHash -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> String
-> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx String
"Finished" TranscriptHash -> Handshake13 -> RecvHandshake13M IO ()
expectFinished'
                    Context -> RecvHandshake13M IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx

expectFinished
    :: MonadIO m
    => ServerParams
    -> Context
    -> [ExtensionRaw]
    -> SecretTriple ApplicationSecret
    -> ClientTrafficSecret HandshakeSecret
    -> Word64
    -> TranscriptHash
    -> Handshake13
    -> m ()
expectFinished :: forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> TranscriptHash
-> Handshake13
-> m ()
expectFinished ServerParams
sparams Context
ctx [ExtensionRaw]
exts SecretTriple ApplicationSecret
appKey ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Millisecond
sfSentTime TranscriptHash
hChBeforeCf (Finished13 VerifyData
verifyData) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Context -> (TLS13State -> TLS13State) -> IO ()
modifyTLS13State Context
ctx ((TLS13State -> TLS13State) -> IO ())
-> (TLS13State -> TLS13State) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TLS13State
st -> TLS13State
st{tls13stRecvCF = True}
    (Hash
usedHash, Cipher
usedCipher, CryptLevel
_, CertReqContext
_) <- Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getRxRecordState Context
ctx
    let ClientTrafficSecret CertReqContext
chs = ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
    Context
-> Hash -> CertReqContext -> TranscriptHash -> VerifyData -> IO ()
forall (m :: * -> *).
MonadIO m =>
Context
-> Hash -> CertReqContext -> TranscriptHash -> VerifyData -> m ()
checkFinished Context
ctx Hash
usedHash CertReqContext
chs TranscriptHash
hChBeforeCf VerifyData
verifyData
    Context -> IO ()
finishHandshake13 Context
ctx
    Context
-> Hash -> Cipher -> ClientTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret ApplicationSecret
clientApplicationSecret0
    ServerParams
-> Context
-> Cipher
-> [ExtensionRaw]
-> BaseSecret ApplicationSecret
-> Millisecond
-> IO ()
sendNewSessionTicket ServerParams
sparams Context
ctx Cipher
usedCipher [ExtensionRaw]
exts BaseSecret ApplicationSecret
applicationSecret Millisecond
sfSentTime
  where
    applicationSecret :: BaseSecret ApplicationSecret
applicationSecret = SecretTriple ApplicationSecret -> BaseSecret ApplicationSecret
forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple ApplicationSecret
appKey
    clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
clientApplicationSecret0 = SecretTriple ApplicationSecret
-> ClientTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey
expectFinished ServerParams
_ Context
_ [ExtensionRaw]
_ SecretTriple ApplicationSecret
_ ClientTrafficSecret HandshakeSecret
_ Millisecond
_ TranscriptHash
_ Handshake13
hs = String -> Maybe String -> m ()
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
hs) (String -> Maybe String
forall a. a -> Maybe a
Just String
"finished 13")

expectEndOfEarlyData
    :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()
expectEndOfEarlyData :: Context
-> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()
expectEndOfEarlyData Context
ctx ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Handshake13
EndOfEarlyData13 = do
    (Hash
usedHash, Cipher
usedCipher, CryptLevel
_, CertReqContext
_) <- Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getRxRecordState Context
ctx
    Context
-> Hash -> Cipher -> ClientTrafficSecret HandshakeSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
expectEndOfEarlyData Context
_ ClientTrafficSecret HandshakeSecret
_ Handshake13
hs = String -> Maybe String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
hs) (String -> Maybe String
forall a. a -> Maybe a
Just String
"end of early data")

expectCertificate
    :: MonadIO m => ServerParams -> Context -> Handshake13 -> m ()
expectCertificate :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> Handshake13 -> m ()
expectCertificate ServerParams
sparams Context
ctx (Certificate13 CertReqContext
certCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CertReqContext
certCtx CertReqContext -> CertReqContext -> Bool
forall a. Eq a => a -> a -> Bool
/= CertReqContext
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> AlertDescription -> TLSError
Error_Protocol String
"certificate request context MUST be empty" AlertDescription
IllegalParameter
    -- fixme checking _ext
    ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
expectCertificate ServerParams
sparams Context
ctx (CompressedCertificate13 CertReqContext
certCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CertReqContext
certCtx CertReqContext -> CertReqContext -> Bool
forall a. Eq a => a -> a -> Bool
/= CertReqContext
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> AlertDescription -> TLSError
Error_Protocol String
"certificate request context MUST be empty" AlertDescription
IllegalParameter
    -- fixme checking _ext
    ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
expectCertificate ServerParams
_ Context
_ Handshake13
hs = String -> Maybe String -> m ()
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
hs) (String -> Maybe String
forall a. a -> Maybe a
Just String
"certificate 13")

sendNewSessionTicket
    :: ServerParams
    -> Context
    -> Cipher
    -> [ExtensionRaw]
    -> BaseSecret ApplicationSecret
    -> Word64
    -> IO ()
sendNewSessionTicket :: ServerParams
-> Context
-> Cipher
-> [ExtensionRaw]
-> BaseSecret ApplicationSecret
-> Millisecond
-> IO ()
sendNewSessionTicket ServerParams
sparams Context
ctx Cipher
usedCipher [ExtensionRaw]
exts BaseSecret ApplicationSecret
applicationSecret Millisecond
sfSentTime = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sendNST (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Millisecond
cfRecvTime <- IO Millisecond
getCurrentTimeFromBase
    let rtt :: Millisecond
rtt = Millisecond
cfRecvTime Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
sfSentTime
    TicketNonce
nonce <- CertReqContext -> TicketNonce
TicketNonce (CertReqContext -> TicketNonce)
-> IO CertReqContext -> IO TicketNonce
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO CertReqContext
getStateRNG Context
ctx Int
32
    BaseSecret ResumptionSecret
resumptionSecret <- Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret Context
ctx CipherChoice
choice BaseSecret ApplicationSecret
applicationSecret
    let life :: Second
life = Int -> Second
forall {a} {a}. (Num a, Integral a) => a -> a
adjustLifetime (Int -> Second) -> Int -> Second
forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverTicketLifetime ServerParams
sparams
        psk :: CertReqContext
psk = CipherChoice
-> BaseSecret ResumptionSecret -> TicketNonce -> CertReqContext
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionSecret TicketNonce
nonce
    (SessionIDorTicket_
identity, Second
add) <- Second
-> CertReqContext
-> Int
-> Millisecond
-> IO (SessionIDorTicket_, Second)
generateSession Second
life CertReqContext
psk Int
rtt0max Millisecond
rtt
    let nst :: Handshake13
nst = Second
-> Second
-> TicketNonce
-> SessionIDorTicket_
-> Int
-> Handshake13
forall {p}.
Integral p =>
Second
-> Second -> TicketNonce -> SessionIDorTicket_ -> p -> Handshake13
createNewSessionTicket Second
life Second
add TicketNonce
nonce SessionIDorTicket_
identity Int
rtt0max
    Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
nst]
  where
    choice :: CipherChoice
choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
    rtt0max :: Int
rtt0max = Int -> Int
forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverEarlyDataSize ServerParams
sparams
    sendNST :: Bool
sendNST = PskKexMode
PSK_DHE_KE PskKexMode -> [PskKexMode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes

    dhModes :: [PskKexMode]
dhModes = case ExtensionID -> [ExtensionRaw] -> Maybe CertReqContext
extensionLookup ExtensionID
EID_PskKeyExchangeModes [ExtensionRaw]
exts
        Maybe CertReqContext
-> (CertReqContext -> Maybe PskKeyExchangeModes)
-> Maybe PskKeyExchangeModes
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> CertReqContext -> Maybe PskKeyExchangeModes
forall a. Extension a => MessageType -> CertReqContext -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Just (PskKeyExchangeModes [PskKexMode]
ms) -> [PskKexMode]
ms
        Maybe PskKeyExchangeModes
Nothing -> []

    generateSession :: Second
-> CertReqContext
-> Int
-> Millisecond
-> IO (SessionIDorTicket_, Second)
generateSession Second
life CertReqContext
psk Int
maxSize Millisecond
rtt = do
        Session (Just CertReqContext
sessionId) <- Context -> IO Session
newSession Context
ctx
        TLS13TicketInfo
tinfo <- Second
-> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Second
life (Context -> Either Context Second
forall a b. a -> Either a b
Left Context
ctx) (Millisecond -> Maybe Millisecond
forall a. a -> Maybe a
Just Millisecond
rtt)
        SessionData
sdata <- Context
-> Cipher
-> TLS13TicketInfo
-> Int
-> CertReqContext
-> IO SessionData
getSessionData13 Context
ctx Cipher
usedCipher TLS13TicketInfo
tinfo Int
maxSize CertReqContext
psk
        let mgr :: SessionManager
mgr = Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ ServerParams -> Shared
serverShared ServerParams
sparams
        Maybe CertReqContext
mticket <- SessionManager
-> CertReqContext -> SessionData -> IO (Maybe CertReqContext)
sessionEstablish SessionManager
mgr CertReqContext
sessionId SessionData
sdata
        let identity :: SessionIDorTicket_
identity = CertReqContext -> SessionIDorTicket_
SessionIDorTicket_ (CertReqContext -> SessionIDorTicket_)
-> CertReqContext -> SessionIDorTicket_
forall a b. (a -> b) -> a -> b
$ CertReqContext -> Maybe CertReqContext -> CertReqContext
forall a. a -> Maybe a -> a
fromMaybe CertReqContext
sessionId Maybe CertReqContext
mticket
        (SessionIDorTicket_, Second) -> IO (SessionIDorTicket_, Second)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionIDorTicket_
identity, TLS13TicketInfo -> Second
ageAdd TLS13TicketInfo
tinfo)

    createNewSessionTicket :: Second
-> Second -> TicketNonce -> SessionIDorTicket_ -> p -> Handshake13
createNewSessionTicket Second
life Second
add TicketNonce
nonce SessionIDorTicket_
identity p
maxSize =
        Second
-> Second
-> TicketNonce
-> SessionIDorTicket_
-> [ExtensionRaw]
-> Handshake13
NewSessionTicket13 Second
life Second
add TicketNonce
nonce SessionIDorTicket_
identity [ExtensionRaw]
nstExtensions
      where
        earlyDataExt :: ExtensionRaw
earlyDataExt = EarlyDataIndication -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (EarlyDataIndication -> ExtensionRaw)
-> EarlyDataIndication -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ Maybe Second -> EarlyDataIndication
EarlyDataIndication (Maybe Second -> EarlyDataIndication)
-> Maybe Second -> EarlyDataIndication
forall a b. (a -> b) -> a -> b
$ Second -> Maybe Second
forall a. a -> Maybe a
Just (Second -> Maybe Second) -> Second -> Maybe Second
forall a b. (a -> b) -> a -> b
$ p -> Second
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
maxSize
        nstExtensions :: [ExtensionRaw]
nstExtensions = [ExtensionRaw
earlyDataExt]
    adjustLifetime :: a -> a
adjustLifetime a
i
        | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = a
0
        | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
604800 = a
604800
        | Bool
otherwise = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i

expectCertVerify
    :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()
expectCertVerify :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx (TranscriptHash CertReqContext
hChCc) (CertVerify13 (DigitallySigned HashAndSignatureAlgorithm
sigAlg CertReqContext
sig)) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    certs :: CertificateChain
certs@(CertificateChain [SignedExact Certificate]
cc) <-
        Context -> String -> IO CertificateChain
forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
"invalid client certificate chain"
    PubKey
pubkey <- case [SignedExact Certificate]
cc of
        [] -> TLSError -> IO PubKey
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO PubKey) -> TLSError -> IO PubKey
forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
"client certificate missing" AlertDescription
HandshakeFailure
        SignedExact Certificate
c : [SignedExact Certificate]
_ -> PubKey -> IO PubKey
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PubKey -> IO PubKey) -> PubKey -> IO PubKey
forall a b. (a -> b) -> a -> b
$ Certificate -> PubKey
certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c
    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Version -> PubKey -> IO ()
forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
checkDigitalSignatureKey Version
ver PubKey
pubkey
    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ PubKey -> HandshakeM ()
setPublicKey PubKey
pubkey
    Bool
verif <- Context
-> PubKey
-> HashAndSignatureAlgorithm
-> CertReqContext
-> CertReqContext
-> IO Bool
forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> CertReqContext
-> CertReqContext
-> m Bool
checkCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
sigAlg CertReqContext
sig CertReqContext
hChCc
    ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif
expectCertVerify ServerParams
_ Context
_ TranscriptHash
_ Handshake13
hs = String -> Maybe String -> m ()
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
hs) (String -> Maybe String
forall a. a -> Maybe a
Just String
"certificate verify 13")

clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif = do
    if Bool
verif
        then do
            -- When verification succeeds, commit the
            -- client certificate chain to the context.
            --
            Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
            () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
            -- Either verification failed because of an
            -- invalid format (with an error message), or
            -- the signature is wrong.  In either case,
            -- ask the application if it wants to
            -- proceed, we will do that.
            Bool
res <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ServerHooks -> IO Bool
onUnverifiedClientCert (ServerParams -> ServerHooks
serverHooks ServerParams
sparams)
            if Bool
res
                then do
                    -- When verification fails, but the
                    -- application callbacks accepts, we
                    -- also commit the client certificate
                    -- chain to the context.
                    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
                else String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"verification failed"

----------------------------------------------------------------

newCertReqContext :: Context -> IO CertReqContext
newCertReqContext :: Context -> IO CertReqContext
newCertReqContext Context
ctx = Context -> Int -> IO CertReqContext
getStateRNG Context
ctx Int
32

requestCertificateServer :: ServerParams -> Context -> IO Bool
requestCertificateServer :: ServerParams -> Context -> IO Bool
requestCertificateServer ServerParams
sparams Context
ctx = Context -> IO Bool -> IO Bool
handleEx Context
ctx (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Bool
supportsPHA <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13ClientSupportsPHA
    let ok :: Bool
ok = Bool
tls13 Bool -> Bool -> Bool
&& Bool
supportsPHA
    if Bool
ok
        then [Handshake13] -> IO (IORef [Handshake13])
forall a. a -> IO (IORef a)
newIORef [] IO (IORef [Handshake13])
-> (IORef [Handshake13] -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef [Handshake13] -> IO Bool
sendCertReqAndRecv
        else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok
  where
    sendCertReqAndRecv :: IORef [Handshake13] -> IO Bool
sendCertReqAndRecv IORef [Handshake13]
ref = do
        CertReqContext
origCertReqCtx <- Context -> IO CertReqContext
newCertReqContext Context
ctx
        let certReq13 :: Handshake13
certReq13 = ServerParams -> Context -> CertReqContext -> Bool -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx CertReqContext
origCertReqCtx Bool
False
        ()
_ <- Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IO (Saved (Maybe HandshakeState))
-> (Saved (Maybe HandshakeState)
    -> IO (Saved (Maybe HandshakeState)))
-> (Saved (Maybe HandshakeState) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx) (Context
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
restoreHState Context
ctx) ((Saved (Maybe HandshakeState) -> IO ()) -> IO ())
-> (Saved (Maybe HandshakeState) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Saved (Maybe HandshakeState)
_ -> do
                Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
certReq13]
        Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withReadLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Handshake13
clientCert13 <- Context -> IORef [Handshake13] -> IO Handshake13
getHandshake Context
ctx IORef [Handshake13]
ref
            Bool
emptyCert <- ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool
expectClientCertificate ServerParams
sparams Context
ctx CertReqContext
origCertReqCtx Handshake13
clientCert13
            Saved (Maybe HandshakeState)
baseHState <- Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx
            IO CertReqContext -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CertReqContext -> IO ()) -> IO CertReqContext -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake13 -> IO CertReqContext
updateTranscriptHash13 Context
ctx Handshake13
certReq13
            IO CertReqContext -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CertReqContext -> IO ()) -> IO CertReqContext -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake13 -> IO CertReqContext
updateTranscriptHash13 Context
ctx Handshake13
clientCert13
            TranscriptHash
th <- Context -> String -> IO TranscriptHash
forall (m :: * -> *).
MonadIO m =>
Context -> String -> m TranscriptHash
transcriptHash Context
ctx String
"CH..Cert"
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
emptyCert (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Handshake13
certVerify13 <- Context -> IORef [Handshake13] -> IO Handshake13
getHandshake Context
ctx IORef [Handshake13]
ref
                ServerParams -> Context -> TranscriptHash -> Handshake13 -> IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx TranscriptHash
th Handshake13
certVerify13
                IO CertReqContext -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CertReqContext -> IO ()) -> IO CertReqContext -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake13 -> IO CertReqContext
updateTranscriptHash13 Context
ctx Handshake13
certVerify13
            Handshake13
finished13 <- Context -> IORef [Handshake13] -> IO Handshake13
getHandshake Context
ctx IORef [Handshake13]
ref
            Context -> Handshake13 -> IO ()
expectClientFinished Context
ctx Handshake13
finished13
            IO (Saved (Maybe HandshakeState)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Saved (Maybe HandshakeState)) -> IO ())
-> IO (Saved (Maybe HandshakeState)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
restoreHState Context
ctx Saved (Maybe HandshakeState)
baseHState -- fixme
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- saving appdata and key update?
-- error handling
getHandshake :: Context -> IORef [Handshake13] -> IO Handshake13
getHandshake :: Context -> IORef [Handshake13] -> IO Handshake13
getHandshake Context
ctx IORef [Handshake13]
ref = do
    [Handshake13]
hhs <- IORef [Handshake13] -> IO [Handshake13]
forall a. IORef a -> IO a
readIORef IORef [Handshake13]
ref
    if [Handshake13] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Handshake13]
hhs
        then do
            Either TLSError Packet13
ex <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
            (TLSError -> IO Handshake13)
-> (Packet13 -> IO Handshake13)
-> Either TLSError Packet13
-> IO Handshake13
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Context -> TLSError -> IO Handshake13
forall a. Context -> TLSError -> IO a
terminate Context
ctx) Packet13 -> IO Handshake13
process Either TLSError Packet13
ex
        else [Handshake13] -> IO Handshake13
chk [Handshake13]
hhs
  where
    process :: Packet13 -> IO Handshake13
process (Handshake13 [Handshake13]
iss) = [Handshake13] -> IO Handshake13
chk [Handshake13]
iss
    process Packet13
_ =
        Context -> TLSError -> IO Handshake13
forall a. Context -> TLSError -> IO a
terminate Context
ctx (TLSError -> IO Handshake13) -> TLSError -> IO Handshake13
forall a b. (a -> b) -> a -> b
$
            String -> AlertDescription -> TLSError
Error_Protocol String
"post handshake authenticated" AlertDescription
UnexpectedMessage
    chk :: [Handshake13] -> IO Handshake13
chk [] = Context -> IORef [Handshake13] -> IO Handshake13
getHandshake Context
ctx IORef [Handshake13]
ref
    chk (KeyUpdate13 KeyUpdate
mode : [Handshake13]
hs) = do
        Context
-> (Context -> IO (Hash, Cipher, CryptLevel, CertReqContext))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getRxRecordState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxRecordState
        -- Write lock wraps both actions because we don't want another
        -- packet to be sent by another thread before the Tx state is
        -- updated.
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyUpdate
mode KeyUpdate -> KeyUpdate -> Bool
forall a. Eq a => a -> a -> Bool
== KeyUpdate
UpdateRequested) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [KeyUpdate -> Handshake13
KeyUpdate13 KeyUpdate
UpdateNotRequested]
            Context
-> (Context -> IO (Hash, Cipher, CryptLevel, CertReqContext))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getTxRecordState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxRecordState
        [Handshake13] -> IO Handshake13
chk [Handshake13]
hs
    chk (Handshake13
h : [Handshake13]
hs) = do
        IORef [Handshake13] -> [Handshake13] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Handshake13]
ref [Handshake13]
hs
        Handshake13 -> IO Handshake13
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handshake13
h

expectClientCertificate
    :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool
expectClientCertificate :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool
expectClientCertificate ServerParams
sparams Context
ctx CertReqContext
origCertReqCtx (Certificate13 CertReqContext
certReqCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = do
    ServerParams
-> Context
-> CertReqContext
-> CertReqContext
-> CertificateChain
-> IO ()
expectClientCertificate' ServerParams
sparams Context
ctx CertReqContext
origCertReqCtx CertReqContext
certReqCtx CertificateChain
certs
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs
expectClientCertificate ServerParams
sparams Context
ctx CertReqContext
origCertReqCtx (CompressedCertificate13 CertReqContext
certReqCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = do
    ServerParams
-> Context
-> CertReqContext
-> CertReqContext
-> CertificateChain
-> IO ()
expectClientCertificate' ServerParams
sparams Context
ctx CertReqContext
origCertReqCtx CertReqContext
certReqCtx CertificateChain
certs
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs
expectClientCertificate ServerParams
_ Context
_ CertReqContext
_ Handshake13
h = String -> Maybe String -> IO Bool
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected String
"Certificate" (Maybe String -> IO Bool) -> Maybe String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
h

expectClientCertificate'
    :: ServerParams
    -> Context
    -> CertReqContext
    -> CertReqContext
    -> CertificateChain
    -> IO ()
expectClientCertificate' :: ServerParams
-> Context
-> CertReqContext
-> CertReqContext
-> CertificateChain
-> IO ()
expectClientCertificate' ServerParams
sparams Context
ctx CertReqContext
origCertReqCtx CertReqContext
certReqCtx CertificateChain
certs = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CertReqContext
origCertReqCtx CertReqContext -> CertReqContext -> Bool
forall a. Eq a => a -> a -> Bool
/= CertReqContext
certReqCtx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> AlertDescription -> TLSError
Error_Protocol String
"certificate context is wrong" AlertDescription
IllegalParameter
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs

expectClientFinished :: Context -> Handshake13 -> IO ()
expectClientFinished :: Context -> Handshake13 -> IO ()
expectClientFinished Context
ctx (Finished13 VerifyData
verifyData) = do
    (Hash
usedHash, Cipher
_, CryptLevel
level, CertReqContext
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getRxRecordState Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptLevel
level CryptLevel -> CryptLevel -> Bool
forall a. Eq a => a -> a -> Bool
== CryptLevel
CryptApplicationSecret) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> AlertDescription -> TLSError
Error_Protocol
                String
"tried post-handshake authentication without application traffic secret"
                AlertDescription
InternalError
    TranscriptHash
hChBeforeCf <- Context -> String -> IO TranscriptHash
forall (m :: * -> *).
MonadIO m =>
Context -> String -> m TranscriptHash
transcriptHash Context
ctx String
"CH..<CF"
    Context
-> Hash -> CertReqContext -> TranscriptHash -> VerifyData -> IO ()
forall (m :: * -> *).
MonadIO m =>
Context
-> Hash -> CertReqContext -> TranscriptHash -> VerifyData -> m ()
checkFinished Context
ctx Hash
usedHash CertReqContext
applicationSecretN TranscriptHash
hChBeforeCf VerifyData
verifyData
expectClientFinished Context
_ Handshake13
h = String -> Maybe String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected String
"Finished" (Maybe String -> IO ()) -> Maybe String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
h

terminate :: Context -> TLSError -> IO a
terminate :: forall a. Context -> TLSError -> IO a
terminate Context
ctx TLSError
err = do
    let (AlertLevel
level, AlertDescription
desc) = TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
err
        reason :: String
reason = TLSError -> String
errorToAlertMessage TLSError
err
        send :: [(AlertLevel, AlertDescription)] -> IO ()
send = Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ())
-> ([(AlertLevel, AlertDescription)] -> Packet13)
-> [(AlertLevel, AlertDescription)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AlertLevel, AlertDescription)] -> Packet13
Alert13
    IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([(AlertLevel, AlertDescription)] -> IO ()
send [(AlertLevel
level, AlertDescription
desc)]) (\SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    Context -> IO ()
setEOF Context
ctx
    TLSException -> IO a
forall e a. Exception e => e -> IO a
throwIO (TLSException -> IO a) -> TLSException -> IO a
forall a b. (a -> b) -> a -> b
$ Bool -> String -> TLSError -> TLSException
Terminated Bool
False String
reason TLSError
err

handleEx :: Context -> IO Bool -> IO Bool
handleEx :: Context -> IO Bool -> IO Bool
handleEx Context
ctx IO Bool
f = IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException IO Bool
f ((SomeException -> IO Bool) -> IO Bool)
-> (SomeException -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \SomeException
exception -> do
    -- If the error was an Uncontextualized TLSException, we replace the
    -- context with HandshakeFailed. If it's anything else, we convert
    -- it to a string and wrap it with Error_Misc and HandshakeFailed.
    let tlserror :: TLSError
tlserror = case SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
            Just TLSException
e | Uncontextualized TLSError
e' <- TLSException
e -> TLSError
e'
            Maybe TLSException
_ -> String -> TLSError
Error_Misc (SomeException -> String
forall a. Show a => a -> String
show SomeException
exception)
    Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet13
Alert13 [TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
tlserror]
    IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSException -> IO Any
forall e a. Exception e => e -> IO a
throwIO (TLSException -> IO Any) -> TLSException -> IO Any
forall a b. (a -> b) -> a -> b
$ TLSError -> TLSException
PostHandshake TLSError
tlserror
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

----------------------------------------------------------------

keyUpdate
    :: Context
    -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString))
    -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
    -> IO ()
keyUpdate :: Context
-> (Context -> IO (Hash, Cipher, CryptLevel, CertReqContext))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
setState = do
    (Hash
usedHash, Cipher
usedCipher, CryptLevel
level, CertReqContext
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getState Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptLevel
level CryptLevel -> CryptLevel -> Bool
forall a. Eq a => a -> a -> Bool
== CryptLevel
CryptApplicationSecret) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> AlertDescription -> TLSError
Error_Protocol
                String
"tried key update without application traffic secret"
                AlertDescription
InternalError
    let applicationSecretN1 :: CertReqContext
applicationSecretN1 =
            Hash
-> CertReqContext
-> CertReqContext
-> CertReqContext
-> Int
-> CertReqContext
hkdfExpandLabel Hash
usedHash CertReqContext
applicationSecretN CertReqContext
"traffic upd" CertReqContext
"" (Int -> CertReqContext) -> Int -> CertReqContext
forall a b. (a -> b) -> a -> b
$
                Hash -> Int
hashDigestSize Hash
usedHash
    Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
setState Context
ctx Hash
usedHash Cipher
usedCipher (CertReqContext -> AnyTrafficSecret ApplicationSecret
forall a. CertReqContext -> AnyTrafficSecret a
AnyTrafficSecret CertReqContext
applicationSecretN1)

-- | How to update keys in TLS 1.3
data KeyUpdateRequest
    = -- | Unidirectional key update
      OneWay
    | -- | Bidirectional key update (normal case)
      TwoWay
    deriving (KeyUpdateRequest -> KeyUpdateRequest -> Bool
(KeyUpdateRequest -> KeyUpdateRequest -> Bool)
-> (KeyUpdateRequest -> KeyUpdateRequest -> Bool)
-> Eq KeyUpdateRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
== :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
$c/= :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
/= :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
Eq, Int -> KeyUpdateRequest -> ShowS
[KeyUpdateRequest] -> ShowS
KeyUpdateRequest -> String
(Int -> KeyUpdateRequest -> ShowS)
-> (KeyUpdateRequest -> String)
-> ([KeyUpdateRequest] -> ShowS)
-> Show KeyUpdateRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyUpdateRequest -> ShowS
showsPrec :: Int -> KeyUpdateRequest -> ShowS
$cshow :: KeyUpdateRequest -> String
show :: KeyUpdateRequest -> String
$cshowList :: [KeyUpdateRequest] -> ShowS
showList :: [KeyUpdateRequest] -> ShowS
Show)

-- | Updating appication traffic secrets for TLS 1.3.
--   If this API is called for TLS 1.3, 'True' is returned.
--   Otherwise, 'False' is returned.
updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool
updateKey :: forall (m :: * -> *).
MonadIO m =>
Context -> KeyUpdateRequest -> m Bool
updateKey Context
ctx KeyUpdateRequest
way = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tls13 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let req :: KeyUpdate
req = case KeyUpdateRequest
way of
                KeyUpdateRequest
OneWay -> KeyUpdate
UpdateNotRequested
                KeyUpdateRequest
TwoWay -> KeyUpdate
UpdateRequested
        -- Write lock wraps both actions because we don't want another packet to
        -- be sent by another thread before the Tx state is updated.
        Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [KeyUpdate -> Handshake13
KeyUpdate13 KeyUpdate
req]
            Context
-> (Context -> IO (Hash, Cipher, CryptLevel, CertReqContext))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, CertReqContext)
getTxRecordState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxRecordState
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
tls13