{-# 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
ClientRandom
Session
chVersion :: Version
chRandom :: ClientRandom
chSession :: Session
chCiphers :: [CipherId]
chComps :: [CompressionID]
chExtensions :: [ExtensionRaw]
chCiphers :: ClientHello -> [CipherId]
chComps :: ClientHello -> [CompressionID]
chExtensions :: ClientHello -> [ExtensionRaw]
chRandom :: ClientHello -> ClientRandom
chSession :: ClientHello -> Session
chVersion :: ClientHello -> Version
..} = do
    sfSentTime <- IO Millisecond
getCurrentTimeFromBase
    let 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 not authenticated && serverWantClientCert sparams
        then runRecvHandshake13 $ do
            -- RFC 8446 Sec 4.4.3: Clients MUST send this message
            -- whenever authenticating via a certificate (i.e., when the
            -- Certificate message is non-empty).  When sent, this message MUST
            -- appear immediately after the Certificate message and immediately
            -- prior to the Finished message.
            skip <- recvHandshake13 ctx $ expectCertificate sparams ctx
            unless skip $
                recvHandshake13hash ctx "CertVerify" (expectCertVerify sparams ctx)
            recvHandshake13hash ctx "Finished" expectFinished'
            ensureRecvComplete ctx
        else
            if rtt0OK && not (ctxQUICMode ctx)
                then
                    setPendingRecvActions
                        ctx
                        [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret
                        , PendingRecvActionHash True $
                            expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime
                        ]
                else runRecvHandshake13 $ do
                    recvHandshake13hash ctx "Finished" expectFinished'
                    ensureRecvComplete 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}
    (usedHash, usedCipher, _, _) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getRxRecordState Context
ctx
    let ClientTrafficSecret chs = clientHandshakeSecret
    checkFinished ctx usedHash chs hChBeforeCf verifyData
    finishHandshake13 ctx
    setRxRecordState ctx usedHash usedCipher clientApplicationSecret0
    sendNewSessionTicket sparams ctx usedCipher exts applicationSecret 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 = [Char] -> Maybe [Char] -> m ()
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake13 -> [Char]
forall a. Show a => a -> [Char]
show Handshake13
hs) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"finished 13")

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

expectCertificate
    :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool
expectCertificate :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> Handshake13 -> m Bool
expectCertificate ServerParams
sparams Context
ctx (Certificate13 ByteString
certCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = 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 -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
certCtx ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (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
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"certificate request context MUST be empty" AlertDescription
IllegalParameter
    -- fixme checking _ext
    ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx 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
expectCertificate ServerParams
sparams Context
ctx (CompressedCertificate13 ByteString
certCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = 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 -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
certCtx ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (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
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"certificate request context MUST be empty" AlertDescription
IllegalParameter
    -- fixme checking _ext
    ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx 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
expectCertificate ServerParams
_ Context
_ Handshake13
hs = [Char] -> Maybe [Char] -> m Bool
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake13 -> [Char]
forall a. Show a => a -> [Char]
show Handshake13
hs) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"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
    cfRecvTime <- IO Millisecond
getCurrentTimeFromBase
    let rtt = Millisecond
cfRecvTime Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
sfSentTime
    nonce <- TicketNonce <$> getStateRNG ctx 32
    resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret
    let life = Int -> Word32
forall {a} {a}. (Num a, Integral a) => a -> a
adjustLifetime (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverTicketLifetime ServerParams
sparams
        psk = CipherChoice
-> BaseSecret ResumptionSecret -> TicketNonce -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionSecret TicketNonce
nonce
    (identity, add) <- generateSession life psk rtt0max rtt
    let nst = Word32
-> Word32
-> TicketNonce
-> SessionIDorTicket_
-> Int
-> Handshake13
forall {p}.
Integral p =>
Word32
-> Word32 -> TicketNonce -> SessionIDorTicket_ -> p -> Handshake13
createNewSessionTicket Word32
life Word32
add TicketNonce
nonce SessionIDorTicket_
identity Int
rtt0max
    sendPacket13 ctx $ 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 ByteString
extensionLookup ExtensionID
EID_PskKeyExchangeModes [ExtensionRaw]
exts
        Maybe ByteString
-> (ByteString -> 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 -> ByteString -> Maybe PskKeyExchangeModes
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Just (PskKeyExchangeModes [PskKexMode]
ms) -> [PskKexMode]
ms
        Maybe PskKeyExchangeModes
Nothing -> []

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

    createNewSessionTicket :: Word32
-> Word32 -> TicketNonce -> SessionIDorTicket_ -> p -> Handshake13
createNewSessionTicket Word32
life Word32
add TicketNonce
nonce SessionIDorTicket_
identity p
maxSize =
        Word32
-> Word32
-> TicketNonce
-> SessionIDorTicket_
-> [ExtensionRaw]
-> Handshake13
NewSessionTicket13 Word32
life Word32
add TicketNonce
nonce SessionIDorTicket_
identity [ExtensionRaw]
nstExtensions
      where
        nstExtensions :: [ExtensionRaw]
nstExtensions
            | p
maxSize p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
0 = []
            | Bool
otherwise = [ExtensionRaw
earlyDataExt]
          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 Word32 -> EarlyDataIndication
EarlyDataIndication (Maybe Word32 -> EarlyDataIndication)
-> Maybe Word32 -> EarlyDataIndication
forall a b. (a -> b) -> a -> b
$ Word32 -> Maybe Word32
forall a. a -> Maybe a
Just (Word32 -> Maybe Word32) -> Word32 -> Maybe Word32
forall a b. (a -> b) -> a -> b
$ p -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
maxSize
    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 ByteString
hChCc) (CertVerify13 (DigitallySigned HashAndSignatureAlgorithm
sigAlg ByteString
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 cc) <-
        Context -> [Char] -> IO CertificateChain
forall (m :: * -> *).
MonadIO m =>
Context -> [Char] -> m CertificateChain
checkValidClientCertChain Context
ctx [Char]
"invalid client certificate chain"
    pubkey <- case 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
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"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
    ver <- usingState_ ctx getVersion
    checkDigitalSignatureKey ver pubkey
    usingHState ctx $ setPublicKey pubkey
    verif <- checkCertVerify ctx pubkey sigAlg sig hChCc
    clientCertVerify sparams ctx certs verif
expectCertVerify ServerParams
_ Context
_ TranscriptHash
_ Handshake13
hs = [Char] -> Maybe [Char] -> m ()
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake13 -> [Char]
forall a. Show a => a -> [Char]
show Handshake13
hs) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"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.
            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 res
                then do
                    -- When verification fails, but the
                    -- application callbacks accepts, we
                    -- also commit the client certificate
                    -- chain to the context.
                    usingState_ ctx $ setClientCertificateChain certs
                else decryptError "verification failed"

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

newCertReqContext :: Context -> IO CertReqContext
newCertReqContext :: Context -> IO ByteString
newCertReqContext Context
ctx = Context -> Int -> IO ByteString
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
    tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA
    let ok = Bool
tls13 Bool -> Bool -> Bool
&& Bool
supportsPHA
    if ok
        then newIORef [] >>= sendCertReqAndRecv
        else return ok
  where
    sendCertReqAndRecv :: IORef [Handshake13R] -> IO Bool
sendCertReqAndRecv IORef [Handshake13R]
ref = do
        origCertReqCtx <- Context -> IO ByteString
newCertReqContext Context
ctx
        let certReq13 = ServerParams -> Context -> ByteString -> Bool -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
origCertReqCtx Bool
False
        _ <- withWriteLock ctx $ do
            bracket (saveHState ctx) (restoreHState ctx) $ \Saved (Maybe HandshakeState)
_ -> do
                Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> [WireBytes] -> Packet13
Handshake13 [Handshake13
certReq13] []
        withReadLock ctx $ do
            (clientCert13, bClientCert13) <- getHandshake ctx ref
            emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13
            baseHState <- saveHState ctx
            updateTranscriptHash13 ctx (clientCert13, bClientCert13)
            th <- transcriptHash ctx "CH..Cert"
            unless emptyCert $ do
                (certVerify13, bCertVerify13) <- getHandshake ctx ref
                expectCertVerify sparams ctx th certVerify13
                updateTranscriptHash13 ctx (certVerify13, bCertVerify13)
            (finished13, _bFinished13) <- getHandshake ctx ref
            expectClientFinished ctx finished13
            void $ restoreHState ctx baseHState -- fixme
        return True

-- saving appdata and key update?
-- error handling
getHandshake
    :: Context -> IORef [Handshake13R] -> IO Handshake13R
getHandshake :: Context -> IORef [Handshake13R] -> IO Handshake13R
getHandshake Context
ctx IORef [Handshake13R]
ref = do
    hhs <- IORef [Handshake13R] -> IO [Handshake13R]
forall a. IORef a -> IO a
readIORef IORef [Handshake13R]
ref
    if null hhs
        then do
            ex <- recvPacket13 ctx
            either (terminate ctx) process ex
        else chk hhs
  where
    process :: Packet13 -> IO Handshake13R
process (Handshake13 [Handshake13]
hss [WireBytes]
bss) = [Handshake13R] -> IO Handshake13R
chk ([Handshake13R] -> IO Handshake13R)
-> [Handshake13R] -> IO Handshake13R
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> [WireBytes] -> [Handshake13R]
forall a b. [a] -> [b] -> [(a, b)]
zip [Handshake13]
hss [WireBytes]
bss
    process Packet13
_ =
        Context -> TLSError -> IO Handshake13R
forall a. Context -> TLSError -> IO a
terminate Context
ctx (TLSError -> IO Handshake13R) -> TLSError -> IO Handshake13R
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"post handshake authenticated" AlertDescription
UnexpectedMessage
    chk :: [Handshake13R] -> IO Handshake13R
chk [] = Context -> IORef [Handshake13R] -> IO Handshake13R
getHandshake Context
ctx IORef [Handshake13R]
ref
    chk ((KeyUpdate13 KeyUpdate
mode, WireBytes
_) : [Handshake13R]
hbs) = do
        Context
-> (Context -> IO (Hash, Cipher, CryptLevel, ByteString))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, ByteString)
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] -> [WireBytes] -> Packet13
Handshake13 [KeyUpdate -> Handshake13
KeyUpdate13 KeyUpdate
UpdateNotRequested] []
            Context
-> (Context -> IO (Hash, Cipher, CryptLevel, ByteString))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getTxRecordState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxRecordState
        [Handshake13R] -> IO Handshake13R
chk [Handshake13R]
hbs
    chk (Handshake13R
hb : [Handshake13R]
hbs) = do
        IORef [Handshake13R] -> [Handshake13R] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Handshake13R]
ref [Handshake13R]
hbs
        Handshake13R -> IO Handshake13R
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handshake13R
hb

expectClientCertificate
    :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool
expectClientCertificate :: ServerParams -> Context -> ByteString -> Handshake13 -> IO Bool
expectClientCertificate ServerParams
sparams Context
ctx ByteString
origCertReqCtx (Certificate13 ByteString
certReqCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = do
    ServerParams
-> Context -> ByteString -> ByteString -> CertificateChain -> IO ()
expectClientCertificate' ServerParams
sparams Context
ctx ByteString
origCertReqCtx ByteString
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 ByteString
origCertReqCtx (CompressedCertificate13 ByteString
certReqCtx (CertificateChain_ CertificateChain
certs) [[ExtensionRaw]]
_ext) = do
    ServerParams
-> Context -> ByteString -> ByteString -> CertificateChain -> IO ()
expectClientCertificate' ServerParams
sparams Context
ctx ByteString
origCertReqCtx ByteString
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
_ ByteString
_ Handshake13
h = [Char] -> Maybe [Char] -> IO Bool
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected [Char]
"Certificate" (Maybe [Char] -> IO Bool) -> Maybe [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Handshake13 -> [Char]
forall a. Show a => a -> [Char]
show Handshake13
h

expectClientCertificate'
    :: ServerParams
    -> Context
    -> CertReqContext
    -> CertReqContext
    -> CertificateChain
    -> IO ()
expectClientCertificate' :: ServerParams
-> Context -> ByteString -> ByteString -> CertificateChain -> IO ()
expectClientCertificate' ServerParams
sparams Context
ctx ByteString
origCertReqCtx ByteString
certReqCtx CertificateChain
certs = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
origCertReqCtx ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
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
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"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
    (usedHash, _, level, applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getRxRecordState Context
ctx
    unless (level == CryptApplicationSecret) $
        throwCore $
            Error_Protocol
                "tried post-handshake authentication without application traffic secret"
                InternalError
    hChBeforeCf <- transcriptHash ctx "CH..<CF"
    checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData
expectClientFinished Context
_ Handshake13
h = [Char] -> Maybe [Char] -> IO ()
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected [Char]
"Finished" (Maybe [Char] -> IO ()) -> Maybe [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Handshake13 -> [Char]
forall a. Show a => a -> [Char]
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 :: [Char]
reason = TLSError -> [Char]
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. (HasCallStack, Exception e) => e -> IO a
throwIO (TLSException -> IO a) -> TLSException -> IO a
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> TLSError -> TLSException
Terminated Bool
False [Char]
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
_ -> [Char] -> TLSError
Error_Misc (SomeException -> [Char]
forall a. Show a => a -> [Char]
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 (ZonkAny 0) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ZonkAny 0) -> IO ()) -> IO (ZonkAny 0) -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSException -> IO (ZonkAny 0)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (TLSException -> IO (ZonkAny 0)) -> TLSException -> IO (ZonkAny 0)
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, ByteString))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
setState = do
    (usedHash, usedCipher, level, applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getState Context
ctx
    unless (level == CryptApplicationSecret) $
        throwCore $
            Error_Protocol
                "tried key update without application traffic secret"
                InternalError
    let applicationSecretN1 =
            Hash -> ByteString -> ByteString -> ByteString -> Int -> ByteString
hkdfExpandLabel Hash
usedHash ByteString
applicationSecretN ByteString
"traffic upd" ByteString
"" (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$
                Hash -> Int
hashDigestSize Hash
usedHash
    setState ctx usedHash usedCipher (AnyTrafficSecret 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 -> [Char] -> [Char]
[KeyUpdateRequest] -> [Char] -> [Char]
KeyUpdateRequest -> [Char]
(Int -> KeyUpdateRequest -> [Char] -> [Char])
-> (KeyUpdateRequest -> [Char])
-> ([KeyUpdateRequest] -> [Char] -> [Char])
-> Show KeyUpdateRequest
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> KeyUpdateRequest -> [Char] -> [Char]
showsPrec :: Int -> KeyUpdateRequest -> [Char] -> [Char]
$cshow :: KeyUpdateRequest -> [Char]
show :: KeyUpdateRequest -> [Char]
$cshowList :: [KeyUpdateRequest] -> [Char] -> [Char]
showList :: [KeyUpdateRequest] -> [Char] -> [Char]
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
    tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    when tls13 $ do
        let 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.
        withWriteLock ctx $ do
            sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] []
            keyUpdate ctx getTxRecordState setTxRecordState
    return tls13