{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.TLS.Handshake.Common (
    handshakeFailed,
    handleException,
    unexpected,
    newSession,
    ensureNullCompression,
    ticketOrSessionID12,

    -- * sending packets
    sendCCSandFinished,

    -- * receiving packets
    RecvState (..),
    runRecvState,
    runRecvStateHS,
    recvPacketHandshake,
    onRecvStateHandshake,
    ensureRecvComplete,
    processExtendedMainSecret,
    getSessionData,
    storePrivInfo,
    isSupportedGroup,
    checkSupportedGroup,
    errorToAlert,
    errorToAlertMessage,
    expectFinished,
    processCertificate,
    --
    setPeerRecordSizeLimit,
    generateFinished,
    updateTranscriptHash12,
    --
    startHandshake,
    finishHandshake12,
    setServerHelloParameters12,
) where

import Control.Concurrent.MVar
import Control.Exception (IOException, fromException, handle, throwIO)
import Control.Monad.State.Strict
import qualified Data.ByteString as B

import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.Handshake.TranscriptHash
import Network.TLS.IO
import Network.TLS.IO.Encode
import Network.TLS.Imports
import Network.TLS.Measurement
import Network.TLS.Packet
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.Util
import Network.TLS.X509

handshakeFailed :: TLSError -> IO ()
handshakeFailed :: TLSError -> IO ()
handshakeFailed TLSError
err = TLSException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (TLSException -> IO ()) -> TLSException -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> TLSException
HandshakeFailed TLSError
err

handleException :: Context -> IO () -> IO ()
handleException :: Context -> IO () -> IO ()
handleException Context
ctx IO ()
f = IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException IO ()
f ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
exception -> do
    DebugParams -> [Char] -> IO ()
debugError (Context -> DebugParams
ctxDebug Context
ctx) ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
exception
    -- If the error was an Uncontextualized TLSException, we replace the
    -- context with HandshakeFailed. If it's anything else, we convert
    -- it to a string and wrap it with Error_Misc and HandshakeFailed.
    let tlserror :: TLSError
tlserror = case SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
            Just TLSException
e | Uncontextualized TLSError
e' <- TLSException
e -> TLSError
e'
            Maybe TLSException
_ -> [Char] -> TLSError
Error_Misc (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
exception)
    Established
established <- Context -> IO Established
ctxEstablished Context
ctx
    Context -> Established -> IO ()
setEstablished Context
ctx Established
NotEstablished
    (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO ()
ignoreIOErr (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
        if Bool
tls13
            then do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
EarlyDataSending) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO ()
clearTxRecordState Context
ctx
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TLSError
tlserror TLSError -> TLSError -> Bool
forall a. Eq a => a -> a -> Bool
/= TLSError
Error_TCP_Terminate) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$
                        [(AlertLevel, AlertDescription)] -> Packet13
Alert13 [TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
tlserror]
            else Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet
Alert [TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
tlserror]
    TLSError -> IO ()
handshakeFailed TLSError
tlserror
  where
    ignoreIOErr :: IOException -> IO ()
    ignoreIOErr :: IOException -> IO ()
ignoreIOErr IOException
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

errorToAlert :: TLSError -> (AlertLevel, AlertDescription)
errorToAlert :: TLSError -> (AlertLevel, AlertDescription)
errorToAlert (Error_Protocol [Char]
_ AlertDescription
ad) = (AlertLevel
AlertLevel_Fatal, AlertDescription
ad)
errorToAlert (Error_Protocol_Warning [Char]
_ AlertDescription
ad) = (AlertLevel
AlertLevel_Warning, AlertDescription
ad)
errorToAlert (Error_Packet_unexpected [Char]
_ [Char]
_) = (AlertLevel
AlertLevel_Fatal, AlertDescription
UnexpectedMessage)
errorToAlert (Error_Packet_Parsing [Char]
msg)
    | [Char]
"invalid version" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
msg = (AlertLevel
AlertLevel_Fatal, AlertDescription
ProtocolVersion)
    | [Char]
"request_update" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
msg = (AlertLevel
AlertLevel_Fatal, AlertDescription
IllegalParameter)
    | Bool
otherwise = (AlertLevel
AlertLevel_Fatal, AlertDescription
DecodeError)
errorToAlert TLSError
_ = (AlertLevel
AlertLevel_Fatal, AlertDescription
InternalError)

-- | Return the message that a TLS endpoint can add to its local log for the
-- specified library error.
errorToAlertMessage :: TLSError -> String
errorToAlertMessage :: TLSError -> [Char]
errorToAlertMessage (Error_Protocol [Char]
msg AlertDescription
_) = [Char]
msg
errorToAlertMessage (Error_Protocol_Warning [Char]
msg AlertDescription
_) = [Char]
msg
errorToAlertMessage (Error_Packet_unexpected [Char]
msg [Char]
_) = [Char]
msg
errorToAlertMessage (Error_Packet_Parsing [Char]
msg) = [Char]
msg
errorToAlertMessage TLSError
e = TLSError -> [Char]
forall a. Show a => a -> [Char]
show TLSError
e

unexpected :: MonadIO m => String -> Maybe String -> m a
unexpected :: forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected [Char]
msg Maybe [Char]
expected =
    TLSError -> m a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m a) -> TLSError -> m a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> TLSError
Error_Packet_unexpected [Char]
msg ([Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" expected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) Maybe [Char]
expected)

newSession :: Context -> IO Session
newSession :: Context -> IO Session
newSession Context
ctx
    | Supported -> Bool
supportedSession (Supported -> Bool) -> Supported -> Bool
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx = Maybe ByteString -> Session
Session (Maybe ByteString -> Session)
-> (ByteString -> Maybe ByteString) -> ByteString -> Session
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Session) -> IO ByteString -> IO Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO ByteString
getStateRNG Context
ctx Int
32
    | Bool
otherwise = Session -> IO Session
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Session -> IO Session) -> Session -> IO Session
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Session
Session Maybe ByteString
forall a. Maybe a
Nothing

sendCCSandFinished
    :: Context
    -> Role
    -> IO ()
sendCCSandFinished :: Context -> Role -> IO ()
sendCCSandFinished Context
ctx Role
role = do
    Context -> Packet -> IO ()
sendPacket12 Context
ctx Packet
ChangeCipherSpec
    Context -> IO ()
contextFlush Context
ctx
    Context -> IO ()
enablePeerRecordLimit Context
ctx
    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    VerifyData
verifyData <- ByteString -> VerifyData
VerifyData (ByteString -> VerifyData) -> IO ByteString -> IO VerifyData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context -> Version -> Role -> IO ByteString
generateFinished Context
ctx Version
ver Role
role)
    Context -> Packet -> IO ()
sendPacket12 Context
ctx ([Handshake] -> Packet
Handshake [VerifyData -> Handshake
Finished VerifyData
verifyData])
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ VerifyData -> TLSSt ()
setVerifyDataForSend VerifyData
verifyData
    Context -> IO ()
contextFlush Context
ctx

data RecvState m
    = RecvStatePacket (Packet -> m (RecvState m)) -- CCS is not Handshake
    | RecvStateHandshake (Handshake -> m (RecvState m))
    | RecvStateDone

recvPacketHandshake :: Context -> IO [Handshake]
recvPacketHandshake :: Context -> IO [Handshake]
recvPacketHandshake Context
ctx = do
    Either TLSError Packet
pkts <- Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx
    case Either TLSError Packet
pkts of
        Right (Handshake [Handshake]
l) -> [Handshake] -> IO [Handshake]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Handshake]
l
        Right x :: Packet
x@(AppData ByteString
_) -> do
            -- If a TLS13 server decides to reject RTT0 data, the server should
            -- skip records for RTT0 data up to the maximum limit.
            Established
established <- Context -> IO Established
ctxEstablished Context
ctx
            case Established
established of
                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 [Handshake]
recvPacketHandshake Context
ctx
                Established
_ -> [Char] -> Maybe [Char] -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Packet -> [Char]
forall a. Show a => a -> [Char]
show Packet
x) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"handshake")
        Right Packet
x -> [Char] -> Maybe [Char] -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Packet -> [Char]
forall a. Show a => a -> [Char]
show Packet
x) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"handshake")
        Left TLSError
err -> TLSError -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
err

-- | process a list of handshakes message in the recv state machine.
onRecvStateHandshake
    :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
_ RecvState IO
recvState [] = RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
recvState
onRecvStateHandshake Context
_ (RecvStatePacket Packet -> IO (RecvState IO)
f) [Handshake]
hms = Packet -> IO (RecvState IO)
f ([Handshake] -> Packet
Handshake [Handshake]
hms)
onRecvStateHandshake Context
ctx (RecvStateHandshake Handshake -> IO (RecvState IO)
f) (Handshake
x : [Handshake]
xs) = do
    let finished :: Bool
finished = Handshake -> Bool
isFinished Handshake
x
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
finished (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake -> IO ByteString
updateTranscriptHash12 Context
ctx Handshake
x
    RecvState IO
nstate <- Handshake -> IO (RecvState IO)
f Handshake
x
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
finished (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake -> IO ByteString
updateTranscriptHash12 Context
ctx Handshake
x
    Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx RecvState IO
nstate [Handshake]
xs
onRecvStateHandshake Context
_ RecvState IO
RecvStateDone [Handshake]
_xs = [Char] -> Maybe [Char] -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected [Char]
"spurious handshake" Maybe [Char]
forall a. Maybe a
Nothing

isFinished :: Handshake -> Bool
isFinished :: Handshake -> Bool
isFinished Finished{} = Bool
True
isFinished Handshake
_ = Bool
False

runRecvState :: Context -> RecvState IO -> IO ()
runRecvState :: Context -> RecvState IO -> IO ()
runRecvState Context
_ RecvState IO
RecvStateDone = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runRecvState Context
ctx (RecvStatePacket Packet -> IO (RecvState IO)
f) = Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx IO (Either TLSError Packet)
-> (Either TLSError Packet -> IO (RecvState IO))
-> IO (RecvState IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TLSError -> IO (RecvState IO))
-> (Packet -> IO (RecvState IO))
-> Either TLSError Packet
-> IO (RecvState IO)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TLSError -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore Packet -> IO (RecvState IO)
f IO (RecvState IO) -> (RecvState IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> IO ()
runRecvState Context
ctx
runRecvState Context
ctx RecvState IO
iniState =
    Context -> IO [Handshake]
recvPacketHandshake Context
ctx
        IO [Handshake]
-> ([Handshake] -> IO (RecvState IO)) -> IO (RecvState IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx RecvState IO
iniState
        IO (RecvState IO) -> (RecvState IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> IO ()
runRecvState Context
ctx

runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()
runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()
runRecvStateHS Context
ctx RecvState IO
iniState [Handshake]
hs = Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx RecvState IO
iniState [Handshake]
hs IO (RecvState IO) -> (RecvState IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> IO ()
runRecvState Context
ctx

ensureRecvComplete :: MonadIO m => Context -> m ()
ensureRecvComplete :: forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx = do
    Bool
complete <- 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
$ Context -> IO Bool
isRecvComplete Context
ctx
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
complete (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> m ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m ()) -> TLSError -> m ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"received incomplete message at key change" AlertDescription
UnexpectedMessage

processExtendedMainSecret
    :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMainSecret :: forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMainSecret Context
ctx Version
ver MessageType
msgt [ExtensionRaw]
exts
    | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
TLS10 = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
TLS12 = [Char] -> m Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"EMS processing is not compatible with TLS 1.3"
    | EMSMode
ems EMSMode -> EMSMode -> Bool
forall a. Eq a => a -> a -> Bool
== EMSMode
NoEMS = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise =
        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
$
            ExtensionID
-> MessageType
-> [ExtensionRaw]
-> IO Bool
-> (ExtendedMainSecret -> IO Bool)
-> IO Bool
forall a b.
Extension a =>
ExtensionID
-> MessageType -> [ExtensionRaw] -> IO b -> (a -> IO b) -> IO b
lookupAndDecodeAndDo
                ExtensionID
EID_ExtendedMainSecret
                MessageType
msgt
                [ExtensionRaw]
exts
                IO Bool
nonExistAction
                ExtendedMainSecret -> IO Bool
forall {m :: * -> *}. MonadIO m => ExtendedMainSecret -> m Bool
existAction
  where
    ems :: EMSMode
ems = Supported -> EMSMode
supportedExtendedMainSecret (Supported -> EMSMode) -> Supported -> EMSMode
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
    err :: [Char]
err = [Char]
"peer does not support Extended Main Secret"
    nonExistAction :: IO Bool
nonExistAction =
        if EMSMode
ems EMSMode -> EMSMode -> Bool
forall a. Eq a => a -> a -> Bool
== EMSMode
RequireEMS
            then TLSError -> IO Bool
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Bool) -> TLSError -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
err AlertDescription
HandshakeFailure
            else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    existAction :: ExtendedMainSecret -> m Bool
existAction ExtendedMainSecret
ExtendedMainSecret = do
        Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setExtendedMainSecret Bool
True
        Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

getSessionData :: Context -> IO (Maybe SessionData)
getSessionData :: Context -> IO (Maybe SessionData)
getSessionData Context
ctx = do
    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Maybe [Char]
sni <- Context -> TLSSt (Maybe [Char]) -> IO (Maybe [Char])
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe [Char])
getClientSNI
    Maybe ByteString
mms <- Context -> HandshakeM (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM (Maybe ByteString) -> IO (Maybe ByteString))
-> HandshakeM (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (HandshakeState -> Maybe ByteString)
-> HandshakeM (Maybe ByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HandshakeState -> Maybe ByteString
hstMainSecret
    Bool
ems <- Context -> HandshakeM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getExtendedMainSecret
    Word16
cipher <- Cipher -> Word16
cipherID (Cipher -> Word16) -> IO Cipher -> IO Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> HandshakeM Cipher -> IO Cipher
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
    Maybe ByteString
alpn <- Context -> TLSSt (Maybe ByteString) -> IO (Maybe ByteString)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe ByteString)
getNegotiatedProtocol
    let compression :: CompressionID
compression = CompressionID
0
        flags :: [SessionFlag]
flags = [SessionFlag
SessionEMS | Bool
ems]
    case Maybe ByteString
mms of
        Maybe ByteString
Nothing -> Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
        Just ByteString
ms ->
            Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SessionData -> IO (Maybe SessionData))
-> Maybe SessionData -> IO (Maybe SessionData)
forall a b. (a -> b) -> a -> b
$
                SessionData -> Maybe SessionData
forall a. a -> Maybe a
Just
                    SessionData
                        { sessionVersion :: Version
sessionVersion = Version
ver
                        , sessionCipher :: Word16
sessionCipher = Word16
cipher
                        , sessionCompression :: CompressionID
sessionCompression = CompressionID
compression
                        , sessionClientSNI :: Maybe [Char]
sessionClientSNI = Maybe [Char]
sni
                        , sessionSecret :: ByteString
sessionSecret = ByteString
ms
                        , sessionGroup :: Maybe Group
sessionGroup = Maybe Group
forall a. Maybe a
Nothing
                        , sessionTicketInfo :: Maybe TLS13TicketInfo
sessionTicketInfo = Maybe TLS13TicketInfo
forall a. Maybe a
Nothing
                        , sessionALPN :: Maybe ByteString
sessionALPN = Maybe ByteString
alpn
                        , sessionMaxEarlyDataSize :: Int
sessionMaxEarlyDataSize = Int
0
                        , sessionFlags :: [SessionFlag]
sessionFlags = [SessionFlag]
flags
                        }

-- | Store the specified keypair.  Whether the public key and private key
-- actually match is left for the peer to discover.  We're not presently
-- burning  CPU to detect that misconfiguration.  We verify only that the
-- types of keys match and that it does not include an algorithm that would
-- not be safe.
storePrivInfo
    :: MonadIO m
    => Context
    -> CertificateChain
    -> PrivKey
    -> m PubKey
storePrivInfo :: forall (m :: * -> *).
MonadIO m =>
Context -> CertificateChain -> PrivKey -> m PubKey
storePrivInfo Context
ctx CertificateChain
cc PrivKey
privkey = do
    let c :: SignedExact Certificate
c = CertificateChain -> SignedExact Certificate
fromCC CertificateChain
cc
        pubkey :: PubKey
pubkey = Certificate -> PubKey
certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((PubKey, PrivKey) -> Bool
isDigitalSignaturePair (PubKey
pubkey, PrivKey
privkey)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> m ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m ()) -> TLSError -> m ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"mismatched or unsupported private key pair" AlertDescription
InternalError
    Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ (PubKey, PrivKey) -> HandshakeM ()
setPublicPrivateKeys (PubKey
pubkey, PrivKey
privkey)
    PubKey -> m PubKey
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PubKey
pubkey
  where
    fromCC :: CertificateChain -> SignedExact Certificate
fromCC (CertificateChain (SignedExact Certificate
c : [SignedExact Certificate]
_)) = SignedExact Certificate
c
    fromCC CertificateChain
_ = [Char] -> SignedExact Certificate
forall a. HasCallStack => [Char] -> a
error [Char]
"fromCC"

-- verify that the group selected by the peer is supported in the local
-- configuration
checkSupportedGroup :: Context -> Group -> IO ()
checkSupportedGroup :: Context -> Group -> IO ()
checkSupportedGroup Context
ctx Group
grp =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Group -> Bool
isSupportedGroup Context
ctx Group
grp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        let msg :: [Char]
msg = [Char]
"unsupported (EC)DHE group: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Group -> [Char]
forall a. Show a => a -> [Char]
show Group
grp
         in TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
msg AlertDescription
IllegalParameter

isSupportedGroup :: Context -> Group -> Bool
isSupportedGroup :: Context -> Group -> Bool
isSupportedGroup Context
ctx Group
grp = Group
grp Group -> [Group] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)

ensureNullCompression :: MonadIO m => CompressionID -> m ()
ensureNullCompression :: forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression CompressionID
compression =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompressionID
compression CompressionID -> CompressionID -> Bool
forall a. Eq a => a -> a -> Bool
/= Compression -> CompressionID
compressionID Compression
nullCompression) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> m ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m ()) -> TLSError -> m ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"compression is not allowed in TLS 1.3" AlertDescription
IllegalParameter

expectFinished :: Context -> Handshake -> IO (RecvState IO)
expectFinished :: Context -> Handshake -> IO (RecvState IO)
expectFinished Context
ctx (Finished VerifyData
verifyData) = do
    Context -> VerifyData -> IO ()
processFinished Context
ctx VerifyData
verifyData
    RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
forall (m :: * -> *). RecvState m
RecvStateDone
expectFinished Context
_ Handshake
p = [Char] -> Maybe [Char] -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake -> [Char]
forall a. Show a => a -> [Char]
show Handshake
p) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Handshake Finished")

processFinished :: Context -> VerifyData -> IO ()
processFinished :: Context -> VerifyData -> IO ()
processFinished Context
ctx VerifyData
verifyData = do
    (Role
cc, Version
ver) <- Context -> TLSSt (Role, Version) -> IO (Role, Version)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt (Role, Version) -> IO (Role, Version))
-> TLSSt (Role, Version) -> IO (Role, Version)
forall a b. (a -> b) -> a -> b
$ (,) (Role -> Version -> (Role, Version))
-> TLSSt Role -> TLSSt (Version -> (Role, Version))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TLSSt Role
getRole TLSSt (Version -> (Role, Version))
-> TLSSt Version -> TLSSt (Role, Version)
forall a b. TLSSt (a -> b) -> TLSSt a -> TLSSt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TLSSt Version
getVersion
    VerifyData
expected <- ByteString -> VerifyData
VerifyData (ByteString -> VerifyData) -> IO ByteString -> IO VerifyData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Version -> Role -> IO ByteString
generateFinished Context
ctx Version
ver (Role -> Role
invertRole Role
cc)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VerifyData
expected VerifyData -> VerifyData -> Bool
forall a. Eq a => a -> a -> Bool
/= VerifyData
verifyData) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall (m :: * -> *) a. MonadIO m => [Char] -> m a
decryptError [Char]
"finished verification failed"
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ VerifyData -> TLSSt ()
setVerifyDataForRecv VerifyData
verifyData

processCertificate :: Context -> Role -> CertificateChain -> IO ()
processCertificate :: Context -> Role -> CertificateChain -> IO ()
processCertificate Context
_ Role
ServerRole (CertificateChain []) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
processCertificate Context
_ Role
ClientRole (CertificateChain []) =
    TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"server certificate missing" AlertDescription
HandshakeFailure
processCertificate Context
ctx Role
_ (CertificateChain (SignedExact Certificate
c : [SignedExact Certificate]
_)) =
    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ PubKey -> HandshakeM ()
setPublicKey PubKey
pubkey
  where
    pubkey :: PubKey
pubkey = Certificate -> PubKey
certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c

-- TLS 1.2 distinguishes session ID and session ticket.  session
-- ticket. Session ticket is prioritized over session ID.
ticketOrSessionID12
    :: Maybe Ticket -> Session -> Maybe SessionIDorTicket
ticketOrSessionID12 :: Maybe ByteString -> Session -> Maybe ByteString
ticketOrSessionID12 (Just ByteString
ticket) Session
_
    | ByteString
ticket ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"" = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.copy ByteString
ticket
ticketOrSessionID12 Maybe ByteString
_ (Session (Just ByteString
sessionId)) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.copy ByteString
sessionId
ticketOrSessionID12 Maybe ByteString
_ Session
_ = Maybe ByteString
forall a. Maybe a
Nothing

setPeerRecordSizeLimit :: Context -> Bool -> RecordSizeLimit -> IO ()
setPeerRecordSizeLimit :: Context -> Bool -> RecordSizeLimit -> IO ()
setPeerRecordSizeLimit Context
ctx Bool
tls13 (RecordSizeLimit Word16
n0) = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
n0 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
64) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol ([Char]
"too small recode size limit: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
n0) AlertDescription
IllegalParameter

    -- RFC 8449 Section 4:
    -- Even if a larger record size limit is provided by a peer, an
    -- endpoint MUST NOT send records larger than the protocol-defined
    -- limit, unless explicitly allowed by a future TLS version or
    -- extension.
    let n1 :: Int
n1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n0
        n2 :: Int
n2
            | Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
protolim = Int
protolim
            | Bool
otherwise = Int
n1
    -- Even if peer's value is larger than the protocol-defined
    -- limitation, call "setPeerRecordLimit" to send
    -- "record_size_limit" as ACK.  In this case, the protocol-defined
    -- limitation is used.
    let lim :: Int
lim = if Bool
tls13 then Int
n2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
n2
    Context -> Maybe Int -> IO ()
setPeerRecordLimit Context
ctx (Maybe Int -> IO ()) -> Maybe Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
lim
  where
    protolim :: Int
protolim
        | Bool
tls13 = Int
defaultRecordSizeLimit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        | Bool
otherwise = Int
defaultRecordSizeLimit

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

generateFinished :: Context -> Version -> Role -> IO ByteString
generateFinished :: Context -> Version -> Role -> IO ByteString
generateFinished Context
ctx Version
ver Role
role = do
    TranscriptHash
thash <- Context -> [Char] -> IO TranscriptHash
forall (m :: * -> *).
MonadIO m =>
Context -> [Char] -> m TranscriptHash
transcriptHash Context
ctx [Char]
"generateFinished"
    (ByteString
mainSecret, Cipher
cipher) <- Context
-> HandshakeM (ByteString, Cipher) -> IO (ByteString, Cipher)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM (ByteString, Cipher) -> IO (ByteString, Cipher))
-> HandshakeM (ByteString, Cipher) -> IO (ByteString, Cipher)
forall a b. (a -> b) -> a -> b
$ (HandshakeState -> (ByteString, Cipher))
-> HandshakeM (ByteString, Cipher)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((HandshakeState -> (ByteString, Cipher))
 -> HandshakeM (ByteString, Cipher))
-> (HandshakeState -> (ByteString, Cipher))
-> HandshakeM (ByteString, Cipher)
forall a b. (a -> b) -> a -> b
$ \HandshakeState
hst ->
        (Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HandshakeState -> Maybe ByteString
hstMainSecret HandshakeState
hst, Maybe Cipher -> Cipher
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Cipher -> Cipher) -> Maybe Cipher -> Cipher
forall a b. (a -> b) -> a -> b
$ HandshakeState -> Maybe Cipher
hstPendingCipher HandshakeState
hst)
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        if Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole
            then
                Version -> Cipher -> ByteString -> TranscriptHash -> ByteString
generateClientFinished Version
ver Cipher
cipher ByteString
mainSecret TranscriptHash
thash
            else
                Version -> Cipher -> ByteString -> TranscriptHash -> ByteString
generateServerFinished Version
ver Cipher
cipher ByteString
mainSecret TranscriptHash
thash

generateFinished'
    :: PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString
generateFinished' :: PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString
generateFinished' PRF
prf ByteString
label ByteString
mainSecret (TranscriptHash ByteString
thash) = PRF
prf ByteString
mainSecret ByteString
seed Int
12
  where
    seed :: ByteString
seed = ByteString
label ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
thash

generateClientFinished
    :: Version
    -> Cipher
    -> ByteString
    -> TranscriptHash
    -> ByteString
generateClientFinished :: Version -> Cipher -> ByteString -> TranscriptHash -> ByteString
generateClientFinished Version
ver Cipher
ciph =
    PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString
generateFinished' (Version -> Cipher -> PRF
getPRF Version
ver Cipher
ciph) ByteString
"client finished"

generateServerFinished
    :: Version
    -> Cipher
    -> ByteString
    -> TranscriptHash
    -> ByteString
generateServerFinished :: Version -> Cipher -> ByteString -> TranscriptHash -> ByteString
generateServerFinished Version
ver Cipher
ciph =
    PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString
generateFinished' (Version -> Cipher -> PRF
getPRF Version
ver Cipher
ciph) ByteString
"server finished"

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

-- initialize a new Handshake context (initial handshake or renegotiations)
startHandshake :: Context -> Version -> ClientRandom -> IO ()
startHandshake :: Context -> Version -> ClientRandom -> IO ()
startHandshake Context
ctx Version
ver ClientRandom
crand =
    IO (Maybe HandshakeState) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe HandshakeState) -> IO ())
-> IO (Maybe HandshakeState) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe HandshakeState)
-> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a. MVar a -> a -> IO a
swapMVar (Context -> MVar (Maybe HandshakeState)
ctxHandshakeState Context
ctx) (Maybe HandshakeState -> IO (Maybe HandshakeState))
-> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a b. (a -> b) -> a -> b
$ HandshakeState -> Maybe HandshakeState
forall a. a -> Maybe a
Just HandshakeState
hs
  where
    hs :: HandshakeState
hs = Version -> ClientRandom -> HandshakeState
newEmptyHandshake Version
ver ClientRandom
crand

setServerHelloParameters12
    :: Context
    -> Version
    -- ^ chosen version
    -> ServerRandom
    -> Cipher
    -> Compression
    -> IO ()
setServerHelloParameters12 :: Context
-> Version -> ServerRandom -> Cipher -> Compression -> IO ()
setServerHelloParameters12 Context
ctx Version
ver ServerRandom
sran Cipher
cipher Compression
compression = do
    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (HandshakeState -> HandshakeState) -> HandshakeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((HandshakeState -> HandshakeState) -> HandshakeM ())
-> (HandshakeState -> HandshakeState) -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ \HandshakeState
hst ->
            HandshakeState
hst
                { hstServerRandom = Just sran
                , hstPendingCipher = Just cipher
                , hstPendingCompression = compression
                }
    Context -> [Char] -> Hash -> Bool -> IO ()
transitTranscriptHash Context
ctx [Char]
"transit" (Version -> Cipher -> Hash
getHash Version
ver Cipher
cipher) Bool
False

-- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384
-- instead of the default SHA256.
getHash :: Version -> Cipher -> Hash
getHash :: Version -> Cipher -> Hash
getHash Version
ver Cipher
ciph
    | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
TLS12 = Hash
SHA1_MD5
    | Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
TLS12) (Cipher -> Maybe Version
cipherMinVer Cipher
ciph) = Hash
SHA256
    | Bool
otherwise = Cipher -> Hash
cipherHash Cipher
ciph

-- | when a new handshake is done, wrap up & clean up.
finishHandshake12 :: Context -> IO ()
finishHandshake12 :: Context -> IO ()
finishHandshake12 Context
ctx = do
    -- forget most handshake data and reset bytes counters.
    MVar (Maybe HandshakeState)
-> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Context -> MVar (Maybe HandshakeState)
ctxHandshakeState Context
ctx) ((Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ())
-> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        Maybe HandshakeState
Nothing -> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HandshakeState
forall a. Maybe a
Nothing
        Just HandshakeState
hshake ->
            Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HandshakeState -> IO (Maybe HandshakeState))
-> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a b. (a -> b) -> a -> b
$
                HandshakeState -> Maybe HandshakeState
forall a. a -> Maybe a
Just
                    (Version -> ClientRandom -> HandshakeState
newEmptyHandshake (HandshakeState -> Version
hstClientVersion HandshakeState
hshake) (HandshakeState -> ClientRandom
hstClientRandom HandshakeState
hshake))
                        { hstServerRandom = hstServerRandom hshake
                        , hstMainSecret = hstMainSecret hshake
                        , hstExtendedMainSecret = hstExtendedMainSecret hshake
                        , hstSupportedGroup = hstSupportedGroup hshake
                        }
    Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
ctx Measurement -> Measurement
resetBytesCounters
    -- mark the secure connection up and running.
    Context -> Established -> IO ()
setEstablished Context
ctx Established
Established