{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK hide #-}

module Network.TLS.Core (
    -- * Internal packet sending and receiving
    sendPacket12,
    recvPacket12,

    -- * Initialisation and Termination of context
    bye,
    handshake,

    -- * Application Layer Protocol Negotiation
    getNegotiatedProtocol,

    -- * Server Name Indication
    getClientSNI,

    -- * High level API
    sendData,
    recvData,
    recvData',
    updateKey,
    KeyUpdateRequest (..),
    requestCertificate,
) where

import qualified Control.Exception as E
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import Data.IORef
import System.Timeout

import Network.TLS.Cipher
import Network.TLS.Context
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.KeySchedule
import Network.TLS.Parameters
import Network.TLS.PostHandshake
import Network.TLS.Session
import Network.TLS.State (getRole, getSession)
import qualified Network.TLS.State as S
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types (
    AnyTrafficSecret (..),
    ApplicationSecret,
    HostName,
    Role (..),
 )
import Network.TLS.Util (catchException, mapChunks_)

-- | Handshake for a new TLS connection
-- This is to be called at the beginning of a connection, and during renegotiation.
-- Don't use this function as the acquire resource of 'bracket'.
handshake :: MonadIO m => Context -> m ()
handshake :: forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
ctx = do
    Context -> m ()
forall (m :: * -> *). MonadIO m => Context -> m ()
handshake_ Context
ctx
    -- Trying to receive an alert of client authentication failure
    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
        role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
        tls13 <- tls13orLater ctx
        sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx
        when (role == ClientRole && tls13 && sentClientCert) $ do
            rtt <- getRTT ctx
            -- This 'timeout' should work.
            mdat <- timeout rtt $ recvData13 ctx
            case mdat of
                Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just ByteString
dat -> Context -> (TLS13State -> TLS13State) -> IO ()
modifyTLS13State Context
ctx ((TLS13State -> TLS13State) -> IO ())
-> (TLS13State -> TLS13State) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TLS13State
st -> TLS13State
st{tls13stPendingRecvData = Just dat}

rttFactor :: Int
rttFactor :: Int
rttFactor = Int
3

getRTT :: Context -> IO Int
getRTT :: Context -> IO Int
getRTT Context
ctx = do
    rtt <- TLS13State -> Millisecond
tls13stRTT (TLS13State -> Millisecond) -> IO TLS13State -> IO Millisecond
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
    let rtt' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Millisecond -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
rtt) Int
10
    return (rtt' * rttFactor * 1000) -- ms to us

-- | Notify the context that this side wants to close connection.
-- This is important that it is called before closing the handle, otherwise
-- the session might not be resumable (for version < TLS1.2).
-- This doesn't actually close the handle.
--
-- Proper usage is as follows:
--
-- > ctx <- contextNew <backend> <params>
-- > handshake ctx
-- > ...
-- > bye
--
-- The following code ensures nothing but is no harm.
--
-- > bracket (contextNew <backend> <params>) bye $ \ctx -> do
-- >   handshake ctx
-- >   ...
bye :: MonadIO m => Context -> m ()
bye :: forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx = 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
    eof <- Context -> IO Bool
ctxEOF Context
ctx
    tls13 <- tls13orLater ctx
    when (tls13 && not eof) $ do
        role <- usingState_ ctx getRole
        if role == ClientRole
            then do
                withWriteLock ctx $ sendCFifNecessary ctx
                -- receiving NewSessionTicket
                let chk = TLS13State -> Bool
tls13stRecvNST (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
                recvNST <- chk
                unless recvNST $ do
                    rtt <- getRTT ctx
                    void $ timeout rtt $ recvHS13 ctx chk
            else do
                -- receiving Client Finished
                let chk = TLS13State -> Bool
tls13stRecvCF (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
                recvCF <- chk
                unless recvCF $ do
                    -- no chance to measure RTT before receiving CF
                    -- fixme: 1sec is good enough?
                    let rtt = Int
1000000
                    void $ timeout rtt $ recvHS13 ctx chk
    bye_ ctx

bye_ :: MonadIO m => Context -> m ()
bye_ :: forall (m :: * -> *). MonadIO m => Context -> m ()
bye_ Context
ctx = 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
    -- Although setEOF is always protected by the read lock, here we don't try
    -- to wrap ctxEOF with it, so that function bye can still be called
    -- concurrently to a blocked recvData.
    eof <- Context -> IO Bool
ctxEOF Context
ctx
    tls13 <- tls13orLater ctx
    unless eof $
        withWriteLock ctx $
            if tls13
                then sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)]
                else sendPacket12 ctx $ Alert [(AlertLevel_Warning, CloseNotify)]

-- | If the ALPN extensions have been used, this will
-- return get the protocol agreed upon.
getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)
getNegotiatedProtocol :: forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
getNegotiatedProtocol Context
ctx = IO (Maybe ByteString) -> m (Maybe ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt (Maybe ByteString) -> IO (Maybe ByteString)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe ByteString)
S.getNegotiatedProtocol

-- | If the Server Name Indication extension has been used, return the
-- hostname specified by the client.
getClientSNI :: MonadIO m => Context -> m (Maybe HostName)
getClientSNI :: forall (m :: * -> *). MonadIO m => Context -> m (Maybe HostName)
getClientSNI Context
ctx = IO (Maybe HostName) -> m (Maybe HostName)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe HostName) -> m (Maybe HostName))
-> IO (Maybe HostName) -> m (Maybe HostName)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
S.getClientSNI

sendCFifNecessary :: Context -> IO ()
sendCFifNecessary :: Context -> IO ()
sendCFifNecessary Context
ctx = do
    st <- Context -> IO TLS13State
getTLS13State Context
ctx
    let recvSF = TLS13State -> Bool
tls13stRecvSF TLS13State
st
        sentCF = TLS13State -> Bool
tls13stSentCF TLS13State
st
    when (recvSF && not sentCF) $ do
        msend <- readIORef (ctxPendingSendAction ctx)
        case msend of
            Maybe (Context -> IO ())
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Context -> IO ()
sendAction -> do
                Context -> IO ()
sendAction Context
ctx
                IORef (Maybe (Context -> IO ()))
-> Maybe (Context -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe (Context -> IO ()))
ctxPendingSendAction Context
ctx) Maybe (Context -> IO ())
forall a. Maybe a
Nothing

-- | sendData sends a bunch of data.
-- It will automatically chunk data to acceptable packet size
sendData :: MonadIO m => Context -> L.ByteString -> m ()
sendData :: forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendData Context
_ ByteString
"" = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendData Context
ctx ByteString
dataToSend = 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
    tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    let sendP ByteString
bs
            | Bool
tls13 = do
                Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Packet13
AppData13 ByteString
bs
                role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
                sentCF <- tls13stSentCF <$> getTLS13State ctx
                rtt0 <- tls13st0RTT <$> getTLS13State ctx
                when (role == ClientRole && rtt0 && not sentCF) $
                    modifyTLS13State ctx $
                        \TLS13State
st -> TLS13State
st{tls13stPendingSentData = tls13stPendingSentData st . (bs :)}
            | Bool
otherwise = Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Packet
AppData ByteString
bs
    when tls13 $ withWriteLock ctx $ sendCFifNecessary ctx
    withWriteLock ctx $ do
        checkValid ctx
        -- All chunks are protected with the same write lock because we don't
        -- want to interleave writes from other threads in the middle of our
        -- possibly large write.
        mlen <- getPeerRecordLimit ctx -- plaintext, dont' adjust for TLS 1.3
        mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend)

-- | Get data out of Data packet, and automatically renegotiate if a Handshake
-- ClientHello is received.  An empty result means EOF.
recvData :: MonadIO m => Context -> m B.ByteString
recvData :: forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx = IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
    tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    withReadLock ctx $ do
        checkValid ctx
        -- We protect with a read lock both reception and processing of the
        -- packet, because don't want another thread to receive a new packet
        -- before this one has been fully processed.
        --
        -- Even when recvData12/recvData13 loops, we only need to call function
        -- checkValid once.  Since we hold the read lock, no concurrent call
        -- will impact the validity of the context.
        if tls13 then recvData13 ctx else recvData12 ctx

recvData12 :: Context -> IO B.ByteString
recvData12 :: Context -> IO ByteString
recvData12 Context
ctx = do
    pkt <- Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx
    either (onError terminate12) process pkt
  where
    process :: Packet -> IO ByteString
process (Handshake [ch :: Handshake
ch@ClientHello{}]) =
        Context -> Handshake -> IO ()
forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
ch IO () -> IO ByteString -> IO ByteString
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData12 Context
ctx
    process (Handshake [hr :: Handshake
hr@Handshake
HelloRequest]) =
        Context -> Handshake -> IO ()
forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
hr IO () -> IO ByteString -> IO ByteString
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData12 Context
ctx
    -- UserCanceled should be followed by a close_notify.
    -- fixme: is it safe to call recvData12?
    process (Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
UserCanceled)]) = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
    process (Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx IO () -> IO ByteString -> IO ByteString
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
    process (Alert [(AlertLevel
AlertLevel_Fatal, AlertDescription
desc)]) = do
        Context -> IO ()
setEOF Context
ctx
        TLSException -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO
            ( Bool -> HostName -> TLSError -> TLSException
Terminated
                Bool
True
                (HostName
"received fatal error: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ AlertDescription -> HostName
forall a. Show a => a -> HostName
show AlertDescription
desc)
                (HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"remote side fatal error" AlertDescription
desc)
            )

    -- when receiving empty appdata, we just retry to get some data.
    process (AppData ByteString
"") = Context -> IO ByteString
recvData12 Context
ctx
    process (AppData ByteString
x) = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
    process Packet
p =
        let reason :: HostName
reason = HostName
"unexpected message " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Packet -> HostName
forall a. Show a => a -> HostName
show Packet
p
         in TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate12 (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason

    terminate12 :: TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate12 = Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ())
-> ([(AlertLevel, AlertDescription)] -> Packet)
-> [(AlertLevel, AlertDescription)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AlertLevel, AlertDescription)] -> Packet
Alert)

recvData13 :: Context -> IO B.ByteString
recvData13 :: Context -> IO ByteString
recvData13 Context
ctx = do
    mdat <- TLS13State -> Maybe ByteString
tls13stPendingRecvData (TLS13State -> Maybe ByteString)
-> IO TLS13State -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
    case mdat of
        Maybe ByteString
Nothing -> do
            pkt <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
            either (onError (terminate13 ctx)) process pkt
        Just ByteString
dat -> 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{tls13stPendingRecvData = Nothing}
            ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
dat
  where
    -- UserCanceled MUST be followed by a CloseNotify.
    process :: Packet13 -> IO ByteString
process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
UserCanceled)]) = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
    process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx IO () -> IO ByteString -> IO ByteString
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
    process (Alert13 [(AlertLevel
AlertLevel_Fatal, AlertDescription
desc)]) = do
        Context -> IO ()
setEOF Context
ctx
        TLSException -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO
            ( Bool -> HostName -> TLSError -> TLSException
Terminated
                Bool
True
                (HostName
"received fatal error: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ AlertDescription -> HostName
forall a. Show a => a -> HostName
show AlertDescription
desc)
                (HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"remote side fatal error" AlertDescription
desc)
            )
    process (Handshake13 [Handshake13]
hs) = do
        [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        Context -> IO ByteString
recvData13 Context
ctx
    -- when receiving empty appdata, we just retry to get some data.
    process (AppData13 ByteString
"") = Context -> IO ByteString
recvData13 Context
ctx
    process (AppData13 ByteString
x) = do
        let chunkLen :: Int
chunkLen = ByteString -> Int
C8.length ByteString
x
        established <- Context -> IO Established
ctxEstablished Context
ctx
        case established of
            EarlyDataAllowed Int
maxSize
                | Int
chunkLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxSize -> do
                    Context -> Established -> IO ()
setEstablished Context
ctx (Established -> IO ()) -> Established -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataAllowed (Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
chunkLen)
                    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
                | Bool
otherwise ->
                    let reason :: HostName
reason = HostName
"early data overflow"
                     in Context
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO ByteString
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
            EarlyDataNotAllowed Int
n
                | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
                    Context -> Established -> IO ()
setEstablished Context
ctx (Established -> IO ()) -> Established -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataNotAllowed (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                    Context -> IO ByteString
recvData13 Context
ctx -- ignore "x"
                | Bool
otherwise ->
                    let reason :: HostName
reason = HostName
"early data deprotect overflow"
                     in Context
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO ByteString
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
            Established
Established -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
            Established
_ -> TLSError -> IO ByteString
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ByteString) -> TLSError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"data at not-established" AlertDescription
UnexpectedMessage
    process Packet13
ChangeCipherSpec13 = do
        established <- Context -> IO Established
ctxEstablished Context
ctx
        if established /= Established
            then recvData13 ctx
            else do
                let reason = HostName
"CSS after Finished"
                terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
    process Packet13
p =
        let reason :: HostName
reason = HostName
"unexpected message " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Packet13 -> HostName
forall a. Show a => a -> HostName
show Packet13
p
         in Context
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO ByteString
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason

    loopHandshake13 :: [Handshake13] -> IO ()
loopHandshake13 [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- fixme: some implementations send multiple NST at the same time.
    -- Only the first one is used at this moment.
    loopHandshake13 (NewSessionTicket13 Second
life Second
add ByteString
nonce ByteString
ticket [ExtensionRaw]
exts : [Handshake13]
hs) = do
        role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.getRole
        unless (role == ClientRole) $
            let reason = HostName
"Session ticket is allowed for client only"
             in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
        -- This part is similar to handshake code, so protected with
        -- read+write locks (which is also what we use for all calls to the
        -- session manager).
        withWriteLock ctx $ do
            Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret
            (_, usedCipher, _, _) <- getTxRecordState ctx
            -- mMaxSize is always Just, but anyway
            let extract (EarlyDataIndication Maybe Second
mMaxSize) =
                    b -> (Second -> b) -> Maybe Second -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
0 (Second -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Second -> b) -> (Second -> Second) -> Second -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Second -> Second
forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32) Maybe Second
mMaxSize
            let choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
                psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionSecret ByteString
nonce
                maxSize =
                    ExtensionID
-> MessageType
-> [ExtensionRaw]
-> Int
-> (EarlyDataIndication -> Int)
-> Int
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
                        ExtensionID
EID_EarlyData
                        MessageType
MsgTNewSessionTicket
                        [ExtensionRaw]
exts
                        Int
0
                        EarlyDataIndication -> Int
forall {b}. Num b => EarlyDataIndication -> b
extract
                life7d = Second -> Second -> Second
forall a. Ord a => a -> a -> a
min Second
life Second
604800 -- 7 days max
            tinfo <- createTLS13TicketInfo life7d (Right add) Nothing
            sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk
            let ticket' = ByteString -> ByteString
B.copy ByteString
ticket
            void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata
            modifyTLS13State ctx $ \TLS13State
st -> TLS13State
st{tls13stRecvNST = True}
        loopHandshake13 hs
    loopHandshake13 (KeyUpdate13 KeyUpdate
mode : [Handshake13]
hs) = do
        let multipleKeyUpdate :: Bool
multipleKeyUpdate = (Handshake13 -> Bool) -> [Handshake13] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Handshake13 -> Bool
isKeyUpdate13 [Handshake13]
hs
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
multipleKeyUpdate (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let reason :: HostName
reason = HostName
"Multiple KeyUpdate is not allowed in one record"
            Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
ctxQUICMode Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let reason :: HostName
reason = HostName
"KeyUpdate is not allowed for QUIC"
            Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
        Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
hs
        established <- Context -> IO Established
ctxEstablished Context
ctx
        -- Though RFC 8446 Sec 4.6.3 does not clearly says,
        -- unidirectional key update is legal.
        -- So, we don't have to check if this key update is corresponding
        -- to key update (update_requested) which we sent.
        if established == Established
            then do
                keyUpdate ctx getRxRecordState 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.
                when (mode == UpdateRequested) $ withWriteLock ctx $ do
                    sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]
                    keyUpdate ctx getTxRecordState setTxRecordState
                loopHandshake13 hs
            else do
                let reason = HostName
"received key update before established"
                terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
    loopHandshake13 (h :: Handshake13
h@CertRequest13{} : [Handshake13]
hs) =
        Context -> Handshake13 -> IO ()
postHandshakeAuthWith Context
ctx Handshake13
h IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
    loopHandshake13 (h :: Handshake13
h@Certificate13{} : [Handshake13]
hs) =
        Context -> Handshake13 -> IO ()
postHandshakeAuthWith Context
ctx Handshake13
h IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
    loopHandshake13 (Handshake13
h : [Handshake13]
hs) = do
        rtt0 <- TLS13State -> Bool
tls13st0RTT (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
        when rtt0 $ case h of
            ServerHello13 ServerRandom
srand Session
_ CipherId
_ [ExtensionRaw]
_ ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerRandom -> Bool
isHelloRetryRequest ServerRandom
srand) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Context -> IO ()
clearTxRecordState Context
ctx
                    let reason :: HostName
reason = HostName
"HRR is not allowed for 0-RTT"
                     in Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
            Handshake13
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        cont <- popAction ctx h hs
        when cont $ loopHandshake13 hs

recvHS13 :: Context -> IO Bool -> IO ()
recvHS13 :: Context -> IO Bool -> IO ()
recvHS13 Context
ctx IO Bool
breakLoop = do
    pkt <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
    -- fixme: Left
    either (\TLSError
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) process pkt
  where
    -- UserCanceled MUST be followed by a CloseNotify.
    process :: Packet13 -> IO ()
process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx
    process (Alert13 [(AlertLevel
AlertLevel_Fatal, AlertDescription
_desc)]) = Context -> IO ()
setEOF Context
ctx
    process (Handshake13 [Handshake13]
hs) = do
        [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        stop <- IO Bool
breakLoop
        unless stop $ recvHS13 ctx breakLoop
    process Packet13
_ = Context -> IO Bool -> IO ()
recvHS13 Context
ctx IO Bool
breakLoop

    loopHandshake13 :: [Handshake13] -> IO ()
loopHandshake13 [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- fixme: some implementations send multiple NST at the same time.
    -- Only the first one is used at this moment.
    loopHandshake13 (NewSessionTicket13 Second
life Second
add ByteString
nonce ByteString
ticket [ExtensionRaw]
exts : [Handshake13]
hs) = do
        role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.getRole
        unless (role == ClientRole) $
            let reason = HostName
"Session ticket is allowed for client only"
             in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
        -- This part is similar to handshake code, so protected with
        -- read+write locks (which is also what we use for all calls to the
        -- session manager).
        withWriteLock ctx $ do
            Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret
            (_, usedCipher, _, _) <- getTxRecordState ctx
            let choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
                psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionSecret ByteString
nonce
                maxSize =
                    ExtensionID
-> MessageType
-> [ExtensionRaw]
-> Int
-> (EarlyDataIndication -> Int)
-> Int
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
                        ExtensionID
EID_EarlyData
                        MessageType
MsgTNewSessionTicket
                        [ExtensionRaw]
exts
                        Int
0
                        (\(EarlyDataIndication Maybe Second
mms) -> Second -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Second -> Int) -> Second -> Int
forall a b. (a -> b) -> a -> b
$ Second -> Second
forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 (Second -> Second) -> Second -> Second
forall a b. (a -> b) -> a -> b
$ Maybe Second -> Second
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Second
mms)
                life7d = Second -> Second -> Second
forall a. Ord a => a -> a -> a
min Second
life Second
604800 -- 7 days max
            tinfo <- createTLS13TicketInfo life7d (Right add) Nothing
            sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk
            let ticket' = ByteString -> ByteString
B.copy ByteString
ticket
            void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata
            modifyTLS13State ctx $ \TLS13State
st -> TLS13State
st{tls13stRecvNST = True}
        loopHandshake13 hs
    loopHandshake13 (Handshake13
h : [Handshake13]
hs) = do
        cont <- Context -> Handshake13 -> [Handshake13] -> IO Bool
popAction Context
ctx Handshake13
h [Handshake13]
hs
        when cont $ loopHandshake13 hs

terminate13
    :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a
terminate13 :: forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx = Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (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)

popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool
popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool
popAction Context
ctx Handshake13
h [Handshake13]
hs = do
    mPendingRecvAction <- Context -> IO (Maybe PendingRecvAction)
popPendingRecvAction Context
ctx
    case mPendingRecvAction of
        Maybe PendingRecvAction
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just PendingRecvAction
action -> do
            -- Pending actions are executed with read+write locks, just
            -- like regular handshake code.
            Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Context -> IO () -> IO ()
handleException Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    case PendingRecvAction
action of
                        PendingRecvAction Bool
needAligned Handshake13 -> IO ()
pa -> do
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
hs
                            Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
                            Handshake13 -> IO ()
pa Handshake13
h
                        PendingRecvActionHash Bool
needAligned ByteString -> Handshake13 -> IO ()
pa -> do
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
hs
                            d <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
                            processHandshake13 ctx h
                            pa d h
                    -- Client: after receiving SH, app data is coming.
                    -- this loop tries to receive it.
                    -- App key must be installed before receiving
                    -- the app data.
                    Context -> IO ()
sendCFifNecessary Context
ctx
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

checkAlignment :: Context -> [Handshake13] -> IO ()
checkAlignment :: Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
_hs = do
    complete <- Context -> IO Bool
isRecvComplete Context
ctx
    unless complete $ do
        let reason = HostName
"received message not aligned with record boundary"
        terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason

-- the other side could have close the connection already, so wrap
-- this in a try and ignore all exceptions
tryBye :: Context -> IO ()
tryBye :: Context -> IO ()
tryBye Context
ctx = IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException (Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
bye_ Context
ctx) (\SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

onError
    :: Monad m
    => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)
    -> TLSError
    -> m B.ByteString
onError :: forall (m :: * -> *).
Monad m =>
(TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
_ TLSError
Error_EOF =
    -- Not really an error.
    ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate TLSError
err =
    let (AlertLevel
lvl, AlertDescription
ad) = TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
err
     in TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate TLSError
err AlertLevel
lvl AlertDescription
ad (TLSError -> HostName
errorToAlertMessage TLSError
err)

terminateWithWriteLock
    :: Context
    -> ([(AlertLevel, AlertDescription)] -> IO ())
    -> TLSError
    -> AlertLevel
    -> AlertDescription
    -> String
    -> IO a
terminateWithWriteLock :: forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx [(AlertLevel, AlertDescription)] -> IO ()
send TLSError
err AlertLevel
level AlertDescription
desc HostName
reason = Context -> IO a -> IO a
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    unless tls13 $ do
        -- TLS 1.2 uses the same session ID and session data
        -- for all resumed sessions.
        --
        -- TLS 1.3 changes session data for every resumed session.
        session <- usingState_ ctx getSession
        case session of
            Session Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Session (Just ByteString
sid) ->
                -- calling even session ticket manager anyway
                SessionManager -> ByteString -> IO ()
sessionInvalidate (Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
sid
    catchException (send [(level, desc)]) (\SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    setEOF ctx
    E.throwIO (Terminated False reason err)

{-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}

-- | same as recvData but returns a lazy bytestring.
recvData' :: MonadIO m => Context -> m L.ByteString
recvData' :: forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData' Context
ctx = [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: []) (ByteString -> ByteString) -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> m ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx

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 -> HostName -> HostName
[KeyUpdateRequest] -> HostName -> HostName
KeyUpdateRequest -> HostName
(Int -> KeyUpdateRequest -> HostName -> HostName)
-> (KeyUpdateRequest -> HostName)
-> ([KeyUpdateRequest] -> HostName -> HostName)
-> Show KeyUpdateRequest
forall a.
(Int -> a -> HostName -> HostName)
-> (a -> HostName) -> ([a] -> HostName -> HostName) -> Show a
$cshowsPrec :: Int -> KeyUpdateRequest -> HostName -> HostName
showsPrec :: Int -> KeyUpdateRequest -> HostName -> HostName
$cshow :: KeyUpdateRequest -> HostName
show :: KeyUpdateRequest -> HostName
$cshowList :: [KeyUpdateRequest] -> HostName -> HostName
showList :: [KeyUpdateRequest] -> HostName -> HostName
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