{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
-- |
-- Module      : Network.TLS.Core
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Core
    (
    -- * Internal packet sending and receiving
      sendPacket
    , recvPacket

    -- * 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 Network.TLS.Cipher
import Network.TLS.Context
import Network.TLS.Crypto
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.State (getSession)
import Network.TLS.Parameters
import Network.TLS.IO
import Network.TLS.Session
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.PostHandshake
import Network.TLS.KeySchedule
import Network.TLS.Types (Role(..), HostName, AnyTrafficSecret(..), ApplicationSecret)
import Network.TLS.Util (catchException, mapChunks_)
import Network.TLS.Extension
import qualified Network.TLS.State as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import           Control.Monad (unless, when)
import qualified Control.Exception as E

import Control.Monad.State.Strict

-- | 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
eof forall a b. (a -> b) -> a -> b
$ forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$
        if Bool
tls13 then
            Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet13
Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]
          else
            Context -> Packet -> IO ()
sendPacket Context
ctx 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
S.getClientSNI

-- | 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
ctx ByteString
dataToSend = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    let sendP :: ByteString -> IO ()
sendP
          | Bool
tls13     = Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet13
AppData13
          | Bool
otherwise = Context -> Packet -> IO ()
sendPacket Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet
AppData
    forall a. Context -> IO a -> IO a
withWriteLock Context
ctx 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
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    forall a. Context -> IO a -> IO a
withReadLock Context
ctx 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 recvData1/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
recvData1 Context
ctx

recvData1 :: Context -> IO B.ByteString
recvData1 :: Context -> IO ByteString
recvData1 Context
ctx = do
    Either TLSError Packet
pkt <- Context -> IO (Either TLSError Packet)
recvPacket Context
ctx
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *).
Monad m =>
(TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError 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{}]) =
            forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
ch forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData1 Context
ctx
        process (Handshake [hr :: Handshake
hr@Handshake
HelloRequest]) =
            forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
hr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData1 Context
ctx

        process (Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
            forall e a. Exception e => e -> IO a
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
True (HostName
"received fatal error: " forall a. [a] -> [a] -> [a]
++ 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
recvData1 Context
ctx
        process (AppData ByteString
x)  = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
        process Packet
p            = let reason :: HostName
reason = HostName
"unexpected message " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> HostName
show Packet
p in
                               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 = forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (Context -> Packet -> IO ()
sendPacket Context
ctx 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
    Either TLSError Packet13
pkt <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *).
Monad m =>
(TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate) Packet13 -> IO ByteString
process Either TLSError Packet13
pkt
  where process :: Packet13 -> IO ByteString
process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
UserCanceled)]) = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
        process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
            forall e a. Exception e => e -> IO a
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
True (HostName
"received fatal error: " forall a. [a] -> [a] -> [a]
++ 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 forall a. Ord a => a -> a -> Bool
<= Int
maxSize -> do
                    Context -> Established -> IO ()
setEstablished Context
ctx forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataAllowed (Int
maxSize forall a. Num a => a -> a -> a
- Int
chunkLen)
                    forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
                | Bool
otherwise ->
                    let reason :: HostName
reason = HostName
"early data overflow" in
                    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 forall a. Ord a => a -> a -> Bool
> Int
0     -> do
                    Context -> Established -> IO ()
setEstablished Context
ctx forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataNotAllowed (Int
n 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
                    forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
              Established
Established         -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
              Established
NotEstablished      -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 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"
                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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> HostName
show Packet13
p in
                                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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loopHandshake13 (ClientHello13{}:[Handshake13]
_) = do
            let reason :: HostName
reason = HostName
"Client hello is not allowed"
            forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
        -- 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 <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.isClientContext
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role forall a. Eq a => a -> a -> Bool
== Role
ClientRole) forall a b. (a -> b) -> a -> b
$
                let reason :: HostName
reason = HostName
"Session ticket is allowed for client only"
                 in 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).
            forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
                Just BaseSecret ResumptionSecret
resumptionMasterSecret <- 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)
getTxState 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
resumptionMasterSecret ByteString
nonce
                    maxSize :: Int
maxSize = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_EarlyData [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTNewSessionTicket of
                        Just (EarlyDataIndication (Just Second
ms)) -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 Second
ms
                        Maybe EarlyDataIndication
_                                    -> Int
0
                    life7d :: Second
life7d = 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 (forall a b. b -> Either a b
Right Second
add) 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
                SessionManager -> ByteString -> SessionData -> IO ()
sessionEstablish (Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
label' SessionData
sdata
                -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec"
            [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        loopHandshake13 (KeyUpdate13 KeyUpdate
mode:[Handshake13]
hs) = do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
ctxQUICMode Context
ctx) forall a b. (a -> b) -> a -> b
$ do
                let reason :: HostName
reason = HostName
"KeyUpdate is not allowed for QUIC"
                forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
            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 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)
getRxState forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState
                -- Write lock wraps both actions because we don't want another
                -- packet to be sent by another thread before the Tx state is
                -- updated.
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyUpdate
mode forall a. Eq a => a -> a -> Bool
== KeyUpdate
UpdateRequested) forall a b. (a -> b) -> a -> b
$ forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
                    Context -> Packet13 -> IO ()
sendPacket13 Context
ctx 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)
getTxState forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState
                [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
              else do
                let reason :: HostName
reason = HostName
"received key update before established"
                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) =
            forall (m :: * -> *). MonadIO m => Context -> Handshake13 -> m ()
postHandshakeAuthWith Context
ctx Handshake13
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        loopHandshake13 (h :: Handshake13
h@Certificate13{}:[Handshake13]
hs) =
            forall (m :: * -> *). MonadIO m => Context -> Handshake13 -> m ()
postHandshakeAuthWith Context
ctx Handshake13
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        loopHandshake13 (Handshake13
h:[Handshake13]
hs) = do
            Maybe PendingAction
mPendingAction <- Context -> IO (Maybe PendingAction)
popPendingAction Context
ctx
            case Maybe PendingAction
mPendingAction of
                Maybe PendingAction
Nothing -> let reason :: HostName
reason = HostName
"unexpected handshake message " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> HostName
show Handshake13
h in
                           forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
                Just PendingAction
action -> do
                    -- Pending actions are executed with read+write locks, just
                    -- like regular handshake code.
                    forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ Context -> IO () -> IO ()
handleException Context
ctx forall a b. (a -> b) -> a -> b
$
                        case PendingAction
action of
                            PendingAction Bool
needAligned Handshake13 -> IO ()
pa -> do
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
                                Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handshake13 -> IO ()
pa Handshake13
h
                            PendingActionHash Bool
needAligned ByteString -> Handshake13 -> IO ()
pa -> do
                                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
                                ByteString
d <- 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
                    [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs

        terminate :: TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate = forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (Context -> Packet13 -> IO ()
sendPacket13 Context
ctx 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
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
complete Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
hs) forall a b. (a -> b) -> a -> b
$
                let reason :: HostName
reason = HostName
"received message not aligned with record boundary"
                 in 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 = forall a. IO a -> (SomeException -> IO a) -> IO a
catchException (forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx) (\SomeException
_ -> 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.
            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 <- 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.
    forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
        case Session
session of
            Session Maybe ByteString
Nothing    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Session (Just ByteString
sid) -> SessionManager -> ByteString -> IO ()
sessionInvalidate (Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
sid
        forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([(AlertLevel, AlertDescription)] -> IO ()
send [(AlertLevel
level, AlertDescription
desc)]) (\SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
    Context -> IO ()
setEOF Context
ctx
    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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptLevel
level forall a. Eq a => a -> a -> Bool
== CryptLevel
CryptApplicationSecret) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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
"" 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 (forall a. ByteString -> AnyTrafficSecret a
AnyTrafficSecret ByteString
applicationSecretN1)

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

-- | Updating appication traffic secrets for TLS 1.3.
--   If this API is called for TLS 1.3, 'True' is returned.
--   Otherwise, 'False' is returned.
updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool
updateKey :: forall (m :: * -> *).
MonadIO m =>
Context -> KeyUpdateRequest -> m Bool
updateKey Context
ctx KeyUpdateRequest
way = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tls13 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.
        forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
            Context -> Packet13 -> IO ()
sendPacket13 Context
ctx 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)
getTxState forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
tls13