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

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

        -- * sending packets
        sendCCSandFinished,

        -- * receiving packets
        RecvState (..),
        runRecvState,
        runRecvStateHS,
        recvPacketHandshake,
        onRecvStateHandshake,
        ensureRecvComplete,
        processExtendedMainSecret,
        getSessionData,
        storePrivInfo,
        isSupportedGroup,
        checkSupportedGroup,
        errorToAlert,
        errorToAlertMessage,
        expectFinished,
        processCertificate,
        --
        setPeerRecordSizeLimit,
    ) 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.Process
    import Network.TLS.Handshake.Signature
    import Network.TLS.Handshake.State
    import Network.TLS.Handshake.State13
    import Network.TLS.IO
    import Network.TLS.Imports
    import Network.TLS.Measurement
    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. (HasCallStack, 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
        -- 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 <- Context -> IO Established
    ctxEstablished Context
    ctx
        setEstablished ctx NotEstablished
        handle ignoreIOErr $ do
            tls13 <- tls13orLater ctx
            if tls13
                then do
                    when (established == EarlyDataSending) $ clearTxRecordState ctx
                    when (tlserror /= Error_TCP_Terminate) $
                        sendPacket13 ctx $
                            Alert13 [errorToAlert tlserror]
                else sendPacket12 ctx $ Alert [errorToAlert tlserror]
        handshakeFailed 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 Ticket -> Session
    Session (Maybe Ticket -> Session)
    -> (Ticket -> Maybe Ticket) -> Ticket -> Session
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ticket -> Maybe Ticket
    forall a. a -> Maybe a
    Just (Ticket -> Session) -> IO Ticket -> IO Session
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Context -> Int -> IO Ticket
    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 Ticket -> Session
    Session Maybe Ticket
    forall a. Maybe a
    Nothing

    -- | when a new handshake is done, wrap up & clean up.
    handshakeDone12 :: Context -> IO ()
    handshakeDone12 :: Context -> IO ()
    handshakeDone12 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
        () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    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
        verifyData <-
            Ticket -> VerifyData
    VerifyData
                (Ticket -> VerifyData) -> IO Ticket -> IO VerifyData
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ( Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion IO Version -> (Version -> IO Ticket) -> IO Ticket
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Version
    ver -> Context -> HandshakeM Ticket -> IO Ticket
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM Ticket -> IO Ticket) -> HandshakeM Ticket -> IO Ticket
    forall a b. (a -> b) -> a -> b
    $ Version -> Role -> HandshakeM Ticket
    getHandshakeDigest Version
    ver Role
    role
                    )
        sendPacket12 ctx (Handshake [Finished verifyData])
        usingState_ ctx $ setVerifyDataForSend verifyData
        contextFlush 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
        pkts <- Context -> IO (Either TLSError Packet)
    recvPacket12 Context
    ctx
        case 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 Ticket
    _) -> do
                -- If a TLS13 server decides to reject RTT0 data, the server should
                -- skip records for RTT0 data up to the maximum limit.
                established <- Context -> IO Established
    ctxEstablished Context
    ctx
                case 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
    $ Context -> Handshake -> IO ()
    processHandshake12 Context
    ctx Handshake
    x
        nstate <- Handshake -> IO (RecvState IO)
    f Handshake
    x
        when finished $ processHandshake12 ctx x
        onRecvStateHandshake ctx nstate 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
        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
        unless complete $
            throwCore $
                Error_Protocol "received incomplete message at key change" 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
        ver <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion
        sni <- usingState_ ctx getClientSNI
        mms <- usingHState ctx $ gets hstMainSecret
        ems <- usingHState ctx getExtendedMainSecret
        cipher <- cipherID <$> usingHState ctx getPendingCipher
        alpn <- usingState_ ctx getNegotiatedProtocol
        let compression = CompressionID
    0
            flags = [SessionFlag
    SessionEMS | Bool
    ems]
        case mms of
            Maybe Ticket
    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 Ticket
    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 :: Ticket
    sessionSecret = Ticket
    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 Ticket
    sessionALPN = Maybe Ticket
    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
        (cc, 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
        expected <-
            VerifyData <$> usingHState ctx (getHandshakeDigest ver $ invertRole cc)
        when (expected /= verifyData) $ decryptError "cannot verify finished"
        usingState_ ctx $ setVerifyDataForRecv 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 Ticket -> Session -> Maybe Ticket
    ticketOrSessionID12 (Just Ticket
    ticket) Session
    _
        | Ticket
    ticket Ticket -> Ticket -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Ticket
    "" = Ticket -> Maybe Ticket
    forall a. a -> Maybe a
    Just (Ticket -> Maybe Ticket) -> Ticket -> Maybe Ticket
    forall a b. (a -> b) -> a -> b
    $ Ticket -> Ticket
    B.copy Ticket
    ticket
    ticketOrSessionID12 Maybe Ticket
    _ (Session (Just Ticket
    sessionId)) = Ticket -> Maybe Ticket
    forall a. a -> Maybe a
    Just (Ticket -> Maybe Ticket) -> Ticket -> Maybe Ticket
    forall a b. (a -> b) -> a -> b
    $ Ticket -> Ticket
    B.copy Ticket
    sessionId
    ticketOrSessionID12 Maybe Ticket
    _ Session
    _ = Maybe Ticket
    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