{-# 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 (unless, void, when)
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.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
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
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
        Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
        Bool
sentClientCert <- TLS13State -> Bool
tls13stSentClientCert (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole Bool -> Bool -> Bool
&& Bool
tls13 Bool -> Bool -> Bool
&& Bool
sentClientCert) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Int
rtt <- Context -> IO Int
getRTT Context
ctx
            Maybe ByteString
mdat <- Int -> IO ByteString -> IO (Maybe ByteString)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
rtt (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx
            case Maybe ByteString
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
    Millisecond
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
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Millisecond -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
rtt Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rttFactor Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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
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
    Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
    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 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Role
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
        if Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole
            then do
                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 ()
sendCFifNecessary Context
ctx
                -- receiving NewSessionTicket
                Bool
recvNST <- 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
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
recvNST (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Int
rtt <- Context -> IO Int
getRTT Context
ctx
                    IO (Maybe ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ByteString) -> IO ()) -> IO (Maybe ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString -> IO (Maybe ByteString)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
rtt (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx
            else do
                -- receiving Client Finished
                Bool
recvCF <- 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
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
recvCF (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    -- no chance to measure RTT before receiving CF
                    -- fixme: 1sec is good enough?
                    IO (Maybe ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ByteString) -> IO ()) -> IO (Maybe ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ByteString -> IO (Maybe ByteString)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
1000000 (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx
    Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
bye_ Context
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.
    Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
    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 ()
unless Bool
eof (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
$
            if Bool
tls13
                then Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet13
Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]
                else Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet
Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
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
    TLS13State
st <- Context -> IO TLS13State
getTLS13State Context
ctx
    let recvSF :: Bool
recvSF = TLS13State -> Bool
tls13stRecvSF TLS13State
st
        sentCF :: Bool
sentCF = TLS13State -> Bool
tls13stSentCF TLS13State
st
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
recvSF Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sentCF) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe (Context -> IO ())
msend <- IORef (Maybe (Context -> IO ())) -> IO (Maybe (Context -> IO ()))
forall a. IORef a -> IO a
readIORef (Context -> IORef (Maybe (Context -> IO ()))
ctxPendingSendAction Context
ctx)
        case Maybe (Context -> IO ())
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
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    let sendP :: ByteString -> IO ()
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
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
                Bool
sentCF <- TLS13State -> Bool
tls13stSentCF (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
                Bool
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
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole Bool -> Bool -> Bool
&& Bool
rtt0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sentCF) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Context -> (TLS13State -> TLS13State) -> IO ()
modifyTLS13State Context
ctx ((TLS13State -> TLS13State) -> IO ())
-> (TLS13State -> TLS13State) -> IO ()
forall a b. (a -> b) -> a -> b
$
                        \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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tls13 (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
$ Context -> IO ()
sendCFifNecessary Context
ctx
    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 -> IO ()
checkValid Context
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.
        let len :: Maybe Int
len = Context -> Maybe Int
ctxFragmentSize Context
ctx
        (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Int -> (ByteString -> IO ()) -> ByteString -> IO ()
forall (m :: * -> *) a.
Monad m =>
Maybe Int -> (ByteString -> m a) -> ByteString -> m ()
mapChunks_ Maybe Int
len ByteString -> IO ()
sendP) (ByteString -> [ByteString]
L.toChunks ByteString
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
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Context -> IO ByteString -> IO ByteString
forall a. Context -> IO a -> IO a
withReadLock Context
ctx (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
        Context -> IO ()
checkValid Context
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 Bool
tls13 then Context -> IO ByteString
recvData13 Context
ctx else Context -> IO ByteString
recvData12 Context
ctx

recvData12 :: Context -> IO B.ByteString
recvData12 :: Context -> IO ByteString
recvData12 Context
ctx = do
    Either TLSError Packet
pkt <- Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx
    (TLSError -> IO ByteString)
-> (Packet -> IO ByteString)
-> Either TLSError Packet
-> IO ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((TLSError
 -> AlertLevel -> AlertDescription -> HostName -> IO ByteString)
-> TLSError -> IO ByteString
forall (m :: * -> *).
Monad m =>
(TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate) Packet -> IO ByteString
process Either TLSError Packet
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. 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
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason

    terminate :: TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate = 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
    Maybe ByteString
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 Maybe ByteString
mdat of
        Maybe ByteString
Nothing -> do
            Either TLSError Packet13
pkt <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
            (TLSError -> IO ByteString)
-> (Packet13 -> IO ByteString)
-> Either TLSError Packet13
-> IO ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((TLSError
 -> AlertLevel -> AlertDescription -> HostName -> IO ByteString)
-> TLSError -> IO ByteString
forall (m :: * -> *).
Monad m =>
(TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate) Packet13 -> IO ByteString
process Either TLSError Packet13
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. 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
established <- Context -> IO Established
ctxEstablished Context
ctx
        case Established
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 TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (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 TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (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
established <- Context -> IO Established
ctxEstablished Context
ctx
        if Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
/= Established
Established
            then Context -> IO ByteString
recvData13 Context
ctx
            else do
                let reason :: HostName
reason = HostName
"CSS after Finished"
                TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
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 TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (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
label [ExtensionRaw]
exts : [Handshake13]
hs) = do
        Role
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.getRole
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            let reason :: HostName
reason = HostName
"Session ticket is allowed for client only"
             in TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
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).
        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
            Just BaseSecret ResumptionSecret
resumptionSecret <- Context
-> HandshakeM (Maybe (BaseSecret ResumptionSecret))
-> IO (Maybe (BaseSecret ResumptionSecret))
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe (BaseSecret ResumptionSecret))
getTLS13ResumptionSecret
            (Hash
_, Cipher
usedCipher, CryptLevel
_, ByteString
_) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getTxRecordState Context
ctx
            let choice :: CipherChoice
choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
                psk :: ByteString
psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionSecret ByteString
nonce
                maxSize :: Int
maxSize = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_EarlyData [ExtensionRaw]
exts
                    Maybe ByteString
-> (ByteString -> Maybe EarlyDataIndication)
-> Maybe EarlyDataIndication
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 EarlyDataIndication
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTNewSessionTicket of
                    Just (EarlyDataIndication (Just Second
ms)) -> 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
ms
                    Maybe EarlyDataIndication
_ -> Int
0
                life7d :: Second
life7d = Second -> Second -> Second
forall a. Ord a => a -> a -> a
min Second
life Second
604800 -- 7 days max
            TLS13TicketInfo
tinfo <- Second
-> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Second
life7d (Second -> Either Context Second
forall a b. b -> Either a b
Right Second
add) Maybe Millisecond
forall a. Maybe a
Nothing
            SessionData
sdata <- Context
-> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
getSessionData13 Context
ctx Cipher
usedCipher TLS13TicketInfo
tinfo Int
maxSize ByteString
psk
            let label' :: ByteString
label' = ByteString -> ByteString
B.copy ByteString
label
            IO (Maybe ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ByteString) -> IO ()) -> IO (Maybe ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionManager
-> ByteString -> SessionData -> IO (Maybe ByteString)
sessionEstablish (Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
label' SessionData
sdata
            Context -> (TLS13State -> TLS13State) -> IO ()
modifyTLS13State Context
ctx ((TLS13State -> TLS13State) -> IO ())
-> (TLS13State -> TLS13State) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TLS13State
st -> TLS13State
st{tls13stRecvNST = True}
        [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
    loopHandshake13 (KeyUpdate13 KeyUpdate
mode : [Handshake13]
hs) = do
        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"
            TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
        [Handshake13] -> IO ()
forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
        Established
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 Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
Established
            then 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] -> 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
                [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
            else do
                let reason :: HostName
reason = HostName
"received key update before established"
                TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
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
        Maybe PendingRecvAction
mPendingRecvAction <- Context -> IO (Maybe PendingRecvAction)
popPendingRecvAction Context
ctx
        case Maybe PendingRecvAction
mPendingRecvAction of
            Maybe PendingRecvAction
Nothing ->
                let reason :: HostName
reason = HostName
"unexpected handshake message " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Handshake13 -> HostName
forall a. Show a => a -> HostName
show Handshake13
h
                 in TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
            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
$ [Handshake13] -> IO ()
forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [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
$ [Handshake13] -> IO ()
forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
                                ByteString
d <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
                                Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
                                ByteString -> Handshake13 -> IO ()
pa ByteString
d Handshake13
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
                [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs

    terminate :: TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate = 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)

    checkAlignment :: t a -> IO ()
checkAlignment t a
hs = do
        Bool
complete <- Context -> IO Bool
isRecvComplete Context
ctx
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
complete Bool -> Bool -> Bool
&& t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
hs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            let reason :: HostName
reason = HostName
"received message not aligned with record boundary"
             in TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
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 = do
    Session
session <- Context -> TLSSt Session -> IO Session
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Session
getSession
    -- Session manager is always invoked with read+write locks, so we merge this
    -- with the alert packet being emitted.
    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
        case Session
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) -> 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
        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
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
False HostName
reason TLSError
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
    (Hash
usedHash, Cipher
usedCipher, CryptLevel
level, ByteString
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
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
$
            HostName -> AlertDescription -> TLSError
Error_Protocol
                HostName
"tried key update without application traffic secret"
                AlertDescription
InternalError
    let applicationSecretN1 :: ByteString
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
    Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
setState Context
ctx Hash
usedHash Cipher
usedCipher (ByteString -> AnyTrafficSecret ApplicationSecret
forall a. ByteString -> AnyTrafficSecret a
AnyTrafficSecret ByteString
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
    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, 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
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
tls13