    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE OverloadedStrings #-}
    module Network.TLS.Handshake.Common
        ( handshakeFailed
        , handleException
        , unexpected
        , newSession
        , handshakeTerminate
        -- * sending packets
        , sendChangeCipherAndFinish
        -- * receiving packets
        , recvChangeCipherAndFinish
        , RecvState(..)
        , runRecvState
        , recvPacketHandshake
        , onRecvStateHandshake
        , ensureRecvComplete
        , processExtendedMasterSec
        , extensionLookup
        , getSessionData
        , storePrivInfo
        , isSupportedGroup
        , checkSupportedGroup
        ) where

    import qualified Data.ByteString as B
    import Control.Concurrent.MVar

    import Network.TLS.Parameters
    import Network.TLS.Compression
    import Network.TLS.Context.Internal
    import Network.TLS.Extension
    import Network.TLS.Session
    import Network.TLS.Struct
    import Network.TLS.Struct13
    import Network.TLS.IO
    import Network.TLS.State
    import Network.TLS.Handshake.Key
    import Network.TLS.Handshake.Process
    import Network.TLS.Handshake.State
    import Network.TLS.Record.State
    import Network.TLS.Measurement
    import Network.TLS.Types
    import Network.TLS.Cipher
    import Network.TLS.Crypto
    import Network.TLS.Util
    import Network.TLS.X509
    import Network.TLS.Imports

    import Control.Monad.State.Strict
    import Control.Exception (IOException, handle, fromException, throwIO)

    handshakeFailed :: TLSError -> IO ()
    handshakeFailed :: TLSError -> IO ()
    handshakeFailed err :: 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 ctx :: Context
    ctx f :: 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
    $ \exception :: SomeException
    exception -> do
        let tlserror :: TLSError
    tlserror = TLSError -> Maybe TLSError -> TLSError
    forall a. a -> Maybe a -> a
    fromMaybe (String -> TLSError
    Error_Misc (String -> TLSError) -> String -> TLSError
    forall a b. (a -> b) -> a -> b
    $ SomeException -> String
    forall a. Show a => a -> String
    show SomeException
    exception) (Maybe TLSError -> TLSError) -> Maybe TLSError -> TLSError
    forall a b. (a -> b) -> a -> b
    $ SomeException -> Maybe TLSError
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    exception
        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
                Context -> Packet13 -> IO ()
    forall (m :: * -> *). MonadIO m => Context -> Packet13 -> m ()
    sendPacket13 Context
    ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [(AlertLevel, AlertDescription)] -> Packet13
    Alert13 ([(AlertLevel, AlertDescription)] -> Packet13)
    -> [(AlertLevel, AlertDescription)] -> Packet13
    forall a b. (a -> b) -> a -> b
    $ TLSError -> [(AlertLevel, AlertDescription)]
    errorToAlert TLSError
    tlserror
              else
                Context -> Packet -> IO ()
    forall (m :: * -> *). MonadIO m => Context -> Packet -> m ()
    sendPacket Context
    ctx (Packet -> IO ()) -> Packet -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [(AlertLevel, AlertDescription)] -> Packet
    Alert ([(AlertLevel, AlertDescription)] -> Packet)
    -> [(AlertLevel, AlertDescription)] -> Packet
    forall a b. (a -> b) -> a -> b
    $ TLSError -> [(AlertLevel, AlertDescription)]
    errorToAlert TLSError
    tlserror
        TLSError -> IO ()
    handshakeFailed TLSError
    tlserror
      where
        ignoreIOErr :: IOException -> IO ()
        ignoreIOErr :: IOException -> IO ()
    ignoreIOErr _ = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    errorToAlert :: TLSError -> [(AlertLevel, AlertDescription)]
    errorToAlert :: TLSError -> [(AlertLevel, AlertDescription)]
    errorToAlert (Error_Protocol (_, _, ad :: AlertDescription
    ad))   = [(AlertLevel
    AlertLevel_Fatal, AlertDescription
    ad)]
    errorToAlert (Error_Packet_unexpected _ _) = [(AlertLevel
    AlertLevel_Fatal, AlertDescription
    UnexpectedMessage)]
    errorToAlert (Error_Packet_Parsing _)      = [(AlertLevel
    AlertLevel_Fatal, AlertDescription
    DecodeError)]
    errorToAlert _                             = [(AlertLevel
    AlertLevel_Fatal, AlertDescription
    InternalError)]

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

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

    -- | when a new handshake is done, wrap up & clean up.
    handshakeTerminate :: Context -> IO ()
    handshakeTerminate :: Context -> IO ()
    handshakeTerminate ctx :: Context
    ctx = do
        Session
    session <- Context -> TLSSt Session -> IO Session
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Session
    getSession
        -- only callback the session established if we have a session
        case Session
    session of
            Session (Just sessionId :: SessionID
    sessionId) -> do
                Maybe SessionData
    sessionData <- Context -> IO (Maybe SessionData)
    getSessionData Context
    ctx
                let !sessionId' :: SessionID
    sessionId' = SessionID -> SessionID
    B.copy SessionID
    sessionId
                IO () -> IO ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ SessionManager -> SessionID -> SessionData -> IO ()
    sessionEstablish (Shared -> SessionManager
    sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
    forall a b. (a -> b) -> a -> b
    $ Context -> Shared
    ctxShared Context
    ctx) SessionID
    sessionId' (String -> Maybe SessionData -> SessionData
    forall a. String -> Maybe a -> a
    fromJust "session-data" Maybe SessionData
    sessionData)
            _ -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        -- forget most handshake data and reset bytes counters.
        IO () -> IO ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ MVar (Maybe HandshakeState)
    -> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ (Context -> MVar (Maybe HandshakeState)
    ctxHandshake Context
    ctx) ((Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ())
    -> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \ mhshake :: Maybe HandshakeState
    mhshake ->
            case Maybe HandshakeState
    mhshake of
                Nothing -> Maybe HandshakeState -> IO (Maybe HandshakeState)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe HandshakeState
    forall a. Maybe a
    Nothing
                Just hshake :: HandshakeState
    hshake ->
                    Maybe HandshakeState -> IO (Maybe HandshakeState)
    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 :: Maybe ServerRandom
    hstServerRandom = HandshakeState -> Maybe ServerRandom
    hstServerRandom HandshakeState
    hshake
                        , hstMasterSecret :: Maybe SessionID
    hstMasterSecret = HandshakeState -> Maybe SessionID
    hstMasterSecret HandshakeState
    hshake
                        , hstExtendedMasterSec :: Bool
    hstExtendedMasterSec = HandshakeState -> Bool
    hstExtendedMasterSec HandshakeState
    hshake
                        , hstNegotiatedGroup :: Maybe Group
    hstNegotiatedGroup = HandshakeState -> Maybe Group
    hstNegotiatedGroup HandshakeState
    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 (m :: * -> *) a. Monad m => a -> m a
    return ()

    sendChangeCipherAndFinish :: Context
                              -> Role
                              -> IO ()
    sendChangeCipherAndFinish :: Context -> Role -> IO ()
    sendChangeCipherAndFinish ctx :: Context
    ctx role :: Role
    role = do
        Context -> Packet -> IO ()
    forall (m :: * -> *). MonadIO m => Context -> Packet -> m ()
    sendPacket Context
    ctx Packet
    ChangeCipherSpec
        IO () -> IO ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Context -> IO ()
    contextFlush Context
    ctx
        SessionID
    cf <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion IO Version -> (Version -> IO SessionID) -> IO SessionID
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \ver :: Version
    ver -> Context -> HandshakeM SessionID -> IO SessionID
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM SessionID -> IO SessionID)
    -> HandshakeM SessionID -> IO SessionID
    forall a b. (a -> b) -> a -> b
    $ Version -> Role -> HandshakeM SessionID
    getHandshakeDigest Version
    ver Role
    role
        Context -> Packet -> IO ()
    forall (m :: * -> *). MonadIO m => Context -> Packet -> m ()
    sendPacket Context
    ctx ([Handshake] -> Packet
    Handshake [SessionID -> Handshake
    Finished SessionID
    cf])
        IO () -> IO ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Context -> IO ()
    contextFlush Context
    ctx

    recvChangeCipherAndFinish :: Context -> IO ()
    recvChangeCipherAndFinish :: Context -> IO ()
    recvChangeCipherAndFinish ctx :: Context
    ctx = Context -> RecvState IO -> IO ()
    runRecvState Context
    ctx ((Packet -> IO (RecvState IO)) -> RecvState IO
    forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
    RecvStateNext Packet -> IO (RecvState IO)
    forall (m :: * -> *) (m :: * -> *).
    (MonadIO m, MonadIO m) =>
    Packet -> m (RecvState m)
    expectChangeCipher)
      where expectChangeCipher :: Packet -> m (RecvState m)
    expectChangeCipher ChangeCipherSpec = RecvState m -> m (RecvState m)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RecvState m -> m (RecvState m)) -> RecvState m -> m (RecvState m)
    forall a b. (a -> b) -> a -> b
    $ (Handshake -> m (RecvState m)) -> RecvState m
    forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
    RecvStateHandshake Handshake -> m (RecvState m)
    forall (m :: * -> *) (m :: * -> *).
    MonadIO m =>
    Handshake -> m (RecvState m)
    expectFinish
            expectChangeCipher p :: Packet
    p                = String -> Maybe String -> m (RecvState m)
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Packet -> String
    forall a. Show a => a -> String
    show Packet
    p) (String -> Maybe String
    forall a. a -> Maybe a
    Just "change cipher")
            expectFinish :: Handshake -> m (RecvState m)
    expectFinish (Finished _) = RecvState m -> m (RecvState m)
    forall (m :: * -> *) a. Monad m => a -> m a
    return RecvState m
    forall (m :: * -> *). RecvState m
    RecvStateDone
            expectFinish p :: Handshake
    p            = String -> Maybe String -> m (RecvState m)
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake -> String
    forall a. Show a => a -> String
    show Handshake
    p) (String -> Maybe String
    forall a. a -> Maybe a
    Just "Handshake Finished")

    data RecvState m =
          RecvStateNext (Packet -> m (RecvState m))
        | RecvStateHandshake (Handshake -> m (RecvState m))
        | RecvStateDone

    recvPacketHandshake :: Context -> IO [Handshake]
    recvPacketHandshake :: Context -> IO [Handshake]
    recvPacketHandshake ctx :: Context
    ctx = do
        Either TLSError Packet
    pkts <- Context -> IO (Either TLSError Packet)
    forall (m :: * -> *).
    MonadIO m =>
    Context -> m (Either TLSError Packet)
    recvPacket Context
    ctx
        case Either TLSError Packet
    pkts of
            Right (Handshake l :: [Handshake]
    l) -> [Handshake] -> IO [Handshake]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Handshake]
    l
            Right x :: Packet
    x@(AppData _) -> 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 n :: Int
    n
                        | Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 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
    - 1)
                                      Context -> IO [Handshake]
    recvPacketHandshake Context
    ctx
                    _           -> String -> Maybe String -> IO [Handshake]
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Packet -> String
    forall a. Show a => a -> String
    show Packet
    x) (String -> Maybe String
    forall a. a -> Maybe a
    Just "handshake")
            Right x :: Packet
    x             -> String -> Maybe String -> IO [Handshake]
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Packet -> String
    forall a. Show a => a -> String
    show Packet
    x) (String -> Maybe String
    forall a. a -> Maybe a
    Just "handshake")
            Left err :: TLSError
    err            -> TLSError -> IO [Handshake]
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> 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 _   recvState :: RecvState IO
    recvState [] = RecvState IO -> IO (RecvState IO)
    forall (m :: * -> *) a. Monad m => a -> m a
    return RecvState IO
    recvState
    onRecvStateHandshake _   (RecvStateNext f :: Packet -> IO (RecvState IO)
    f) hms :: [Handshake]
    hms = Packet -> IO (RecvState IO)
    f ([Handshake] -> Packet
    Handshake [Handshake]
    hms)
    onRecvStateHandshake ctx :: Context
    ctx (RecvStateHandshake f :: Handshake -> IO (RecvState IO)
    f) (x :: Handshake
    x:xs :: [Handshake]
    xs) = do
        RecvState IO
    nstate <- Handshake -> IO (RecvState IO)
    f Handshake
    x
        Context -> Handshake -> IO ()
    processHandshake Context
    ctx Handshake
    x
        Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
    onRecvStateHandshake Context
    ctx RecvState IO
    nstate [Handshake]
    xs
    onRecvStateHandshake _ _ _   = String -> Maybe String -> IO (RecvState IO)
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected "spurious handshake" Maybe String
    forall a. Maybe a
    Nothing

    runRecvState :: Context -> RecvState IO -> IO ()
    runRecvState :: Context -> RecvState IO -> IO ()
    runRecvState _    RecvStateDone    = () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    runRecvState ctx :: Context
    ctx (RecvStateNext f :: Packet -> IO (RecvState IO)
    f) = Context -> IO (Either TLSError Packet)
    forall (m :: * -> *).
    MonadIO m =>
    Context -> m (Either TLSError Packet)
    recvPacket Context
    ctx IO (Either TLSError Packet)
    -> (Either TLSError Packet -> IO (RecvState IO))
    -> IO (RecvState IO)
    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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwCore Packet -> IO (RecvState IO)
    f IO (RecvState IO) -> (RecvState IO -> IO ()) -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Context -> RecvState IO -> IO ()
    runRecvState Context
    ctx
    runRecvState ctx :: Context
    ctx iniState :: RecvState IO
    iniState          = Context -> IO [Handshake]
    recvPacketHandshake Context
    ctx IO [Handshake]
    -> ([Handshake] -> IO (RecvState IO)) -> IO (RecvState IO)
    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 (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 :: Context -> m ()
    ensureRecvComplete ctx :: Context
    ctx = do
        Bool
    complete <- IO Bool -> m Bool
    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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwCore (TLSError -> m ()) -> TLSError -> m ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol ("received incomplete message at key change", Bool
    True, AlertDescription
    UnexpectedMessage)

    processExtendedMasterSec :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
    processExtendedMasterSec :: Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
    processExtendedMasterSec ctx :: Context
    ctx ver :: Version
    ver msgt :: MessageType
    msgt exts :: [ExtensionRaw]
    exts
        | Version
    ver Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    < Version
    TLS10  = Bool -> m Bool
    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  = String -> m Bool
    forall a. HasCallStack => String -> a
    error "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 (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
        | Bool
    otherwise    =
            case ExtensionID -> [ExtensionRaw] -> Maybe SessionID
    extensionLookup ExtensionID
    extensionID_ExtendedMasterSecret [ExtensionRaw]
    exts Maybe SessionID
    -> (SessionID -> Maybe ExtendedMasterSecret)
    -> Maybe ExtendedMasterSecret
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> SessionID -> Maybe ExtendedMasterSecret
    forall a. Extension a => MessageType -> SessionID -> Maybe a
    extensionDecode MessageType
    msgt of
                Just ExtendedMasterSecret -> Context -> HandshakeM () -> m ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (Bool -> HandshakeM ()
    setExtendedMasterSec Bool
    True) m () -> m Bool -> m Bool
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Bool -> m Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
                Nothing | EMSMode
    ems EMSMode -> EMSMode -> Bool
    forall a. Eq a => a -> a -> Bool
    == EMSMode
    RequireEMS -> TLSError -> m Bool
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwCore (TLSError -> m Bool) -> TLSError -> m Bool
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    err, Bool
    True, AlertDescription
    HandshakeFailure)
                        | Bool
    otherwise -> Bool -> m Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
      where ems :: EMSMode
    ems = Supported -> EMSMode
    supportedExtendedMasterSec (Context -> Supported
    ctxSupported Context
    ctx)
            err :: String
    err = "peer does not support Extended Master Secret"

    getSessionData :: Context -> IO (Maybe SessionData)
    getSessionData :: Context -> IO (Maybe SessionData)
    getSessionData ctx :: Context
    ctx = do
        Version
    ver <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion
        Maybe String
    sni <- Context -> TLSSt (Maybe String) -> IO (Maybe String)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe String)
    getClientSNI
        Maybe SessionID
    mms <- Context -> HandshakeM (Maybe SessionID) -> IO (Maybe SessionID)
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx ((HandshakeState -> Maybe SessionID) -> HandshakeM (Maybe SessionID)
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets HandshakeState -> Maybe SessionID
    hstMasterSecret)
        !Bool
    ems <- Context -> HandshakeM Bool -> IO Bool
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx HandshakeM Bool
    getExtendedMasterSec
        RecordState
    tx  <- IO RecordState -> IO RecordState
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO RecordState -> IO RecordState)
    -> IO RecordState -> IO RecordState
    forall a b. (a -> b) -> a -> b
    $ MVar RecordState -> IO RecordState
    forall a. MVar a -> IO a
    readMVar (Context -> MVar RecordState
    ctxTxState Context
    ctx)
        Maybe SessionID
    alpn <- Context -> TLSSt (Maybe SessionID) -> IO (Maybe SessionID)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe SessionID)
    getNegotiatedProtocol
        let !cipher :: ExtensionID
    cipher      = Cipher -> ExtensionID
    cipherID (Cipher -> ExtensionID) -> Cipher -> ExtensionID
    forall a b. (a -> b) -> a -> b
    $ String -> Maybe Cipher -> Cipher
    forall a. String -> Maybe a -> a
    fromJust "cipher" (Maybe Cipher -> Cipher) -> Maybe Cipher -> Cipher
    forall a b. (a -> b) -> a -> b
    $ RecordState -> Maybe Cipher
    stCipher RecordState
    tx
            !compression :: CompressionID
    compression = Compression -> CompressionID
    compressionID (Compression -> CompressionID) -> Compression -> CompressionID
    forall a b. (a -> b) -> a -> b
    $ RecordState -> Compression
    stCompression RecordState
    tx
            flags :: [SessionFlag]
    flags = [SessionFlag
    SessionEMS | Bool
    ems]
        case Maybe SessionID
    mms of
            Nothing -> Maybe SessionData -> IO (Maybe SessionData)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing
            Just ms :: SessionID
    ms -> Maybe SessionData -> IO (Maybe SessionData)
    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 :: Version
    -> ExtensionID
    -> CompressionID
    -> Maybe String
    -> SessionID
    -> Maybe Group
    -> Maybe TLS13TicketInfo
    -> Maybe SessionID
    -> Int
    -> [SessionFlag]
    -> SessionData
    SessionData
                            { sessionVersion :: Version
    sessionVersion     = Version
    ver
                            , sessionCipher :: ExtensionID
    sessionCipher      = ExtensionID
    cipher
                            , sessionCompression :: CompressionID
    sessionCompression = CompressionID
    compression
                            , sessionClientSNI :: Maybe String
    sessionClientSNI   = Maybe String
    sni
                            , sessionSecret :: SessionID
    sessionSecret      = SessionID
    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 SessionID
    sessionALPN        = Maybe SessionID
    alpn
                            , sessionMaxEarlyDataSize :: Int
    sessionMaxEarlyDataSize = 0
                            , sessionFlags :: [SessionFlag]
    sessionFlags       = [SessionFlag]
    flags
                            }

    extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe SessionID
    extensionLookup toFind :: ExtensionID
    toFind = (ExtensionRaw -> SessionID)
    -> Maybe ExtensionRaw -> Maybe SessionID
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\(ExtensionRaw _ content :: SessionID
    content) -> SessionID
    content)
                           (Maybe ExtensionRaw -> Maybe SessionID)
    -> ([ExtensionRaw] -> Maybe ExtensionRaw)
    -> [ExtensionRaw]
    -> Maybe SessionID
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ExtensionRaw -> Bool) -> [ExtensionRaw] -> Maybe ExtensionRaw
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find (\(ExtensionRaw eid :: ExtensionID
    eid _) -> ExtensionID
    eid ExtensionID -> ExtensionID -> Bool
    forall a. Eq a => a -> a -> Bool
    == ExtensionID
    toFind)

    -- | 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.
    storePrivInfo :: MonadIO m
                  => Context
                  -> CertificateChain
                  -> PrivKey
                  -> m PubKey
    storePrivInfo :: Context -> CertificateChain -> PrivKey -> m PubKey
    storePrivInfo ctx :: Context
    ctx cc :: CertificateChain
    cc privkey :: PrivKey
    privkey = do
        let CertificateChain (c :: SignedExact Certificate
    c:_) = 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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwCore (TLSError -> m ()) -> TLSError -> m ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol
                ( "mismatched or unsupported private key pair"
                , Bool
    True
                , 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 (m :: * -> *) a. Monad m => a -> m a
    return PubKey
    pubkey

    -- verify that the group selected by the peer is supported in the local
    -- configuration
    checkSupportedGroup :: Context -> Group -> IO ()
    checkSupportedGroup :: Context -> Group -> IO ()
    checkSupportedGroup ctx :: Context
    ctx grp :: 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 :: String
    msg = "unsupported (EC)DHE group: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Group -> String
    forall a. Show a => a -> String
    show Group
    grp
             in TLSError -> IO ()
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    msg, Bool
    True, AlertDescription
    IllegalParameter)

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