{-# 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
    , errorToAlert
    , errorToAlertMessage
    ) 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)
import Data.IORef (writeIORef)

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

errorToAlert :: TLSError -> (AlertLevel, AlertDescription)
errorToAlert :: TLSError -> (AlertLevel, AlertDescription)
errorToAlert (Error_Protocol (String
_, Bool
b, AlertDescription
ad))   = let lvl :: AlertLevel
lvl = if Bool
b then AlertLevel
AlertLevel_Fatal else AlertLevel
AlertLevel_Warning
                                             in (AlertLevel
lvl, AlertDescription
ad)
errorToAlert (Error_Packet_unexpected String
_ String
_) = (AlertLevel
AlertLevel_Fatal, AlertDescription
UnexpectedMessage)
errorToAlert (Error_Packet_Parsing String
msg)
  | String
"invalid version" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
msg      = (AlertLevel
AlertLevel_Fatal, AlertDescription
ProtocolVersion)
  | String
"request_update"  forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
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 -> String
errorToAlertMessage (Error_Protocol (String
msg, Bool
_, AlertDescription
_))    = String
msg
errorToAlertMessage (Error_Packet_unexpected String
msg String
_) = String
msg
errorToAlertMessage (Error_Packet_Parsing String
msg)      = String
msg
errorToAlertMessage TLSError
e                               = forall a. Show a => a -> String
show TLSError
e

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

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

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

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

recvChangeCipherAndFinish :: Context -> IO ()
recvChangeCipherAndFinish :: Context -> IO ()
recvChangeCipherAndFinish Context
ctx = Context -> RecvState IO -> IO ()
runRecvState Context
ctx (forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStateNext forall {m :: * -> *} {m :: * -> *}.
(MonadIO m, MonadIO m) =>
Packet -> m (RecvState m)
expectChangeCipher)
  where expectChangeCipher :: Packet -> m (RecvState m)
expectChangeCipher Packet
ChangeCipherSpec = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake forall {m :: * -> *} {m :: * -> *}.
MonadIO m =>
Handshake -> m (RecvState m)
expectFinish
        expectChangeCipher Packet
p                = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Packet
p) (forall a. a -> Maybe a
Just String
"change cipher")
        expectFinish :: Handshake -> m (RecvState m)
expectFinish (Finished SessionID
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). RecvState m
RecvStateDone
        expectFinish Handshake
p            = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake
p) (forall a. a -> Maybe a
Just String
"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 Context
ctx = do
    Either TLSError Packet
pkts <- Context -> IO (Either TLSError Packet)
recvPacket Context
ctx
    case Either TLSError Packet
pkts of
        Right (Handshake [Handshake]
l) -> forall (m :: * -> *) a. Monad m => a -> m a
return [Handshake]
l
        Right x :: Packet
x@(AppData SessionID
_) -> 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 forall a. Ord a => a -> a -> Bool
> Int
0 -> do Context -> Established -> IO ()
setEstablished Context
ctx forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataNotAllowed (Int
n forall a. Num a => a -> a -> a
- Int
1)
                                  Context -> IO [Handshake]
recvPacketHandshake Context
ctx
                Established
_           -> forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Packet
x) (forall a. a -> Maybe a
Just String
"handshake")
        Right Packet
x             -> forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Packet
x) (forall a. a -> Maybe a
Just String
"handshake")
        Left TLSError
err            -> 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
recvState
onRecvStateHandshake Context
_   (RecvStateNext 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
    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 Context
_ RecvState IO
_ [Handshake]
_   = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected String
"spurious handshake" forall a. Maybe a
Nothing

runRecvState :: Context -> RecvState IO -> IO ()
runRecvState :: Context -> RecvState IO -> IO ()
runRecvState Context
_    RecvState IO
RecvStateDone    = forall (m :: * -> *) a. Monad m => a -> m a
return ()
runRecvState Context
ctx (RecvStateNext Packet -> IO (RecvState IO)
f) = Context -> IO (Either TLSError Packet)
recvPacket Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore Packet -> IO (RecvState IO)
f 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 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 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Context -> IO Bool
isRecvComplete Context
ctx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
complete forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"received incomplete message at key change", Bool
True, AlertDescription
UnexpectedMessage)

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

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

extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe SessionID
extensionLookup ExtensionID
toFind = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ExtensionRaw ExtensionID
_ SessionID
content) -> SessionID
content)
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(ExtensionRaw ExtensionID
eid SessionID
_) -> ExtensionID
eid 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 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 CertificateChain (SignedExact Certificate
c:[SignedExact Certificate]
_) = CertificateChain
cc
        pubkey :: PubKey
pubkey = Certificate -> PubKey
certPubKey forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((PubKey, PrivKey) -> Bool
isDigitalSignaturePair (PubKey
pubkey, PrivKey
privkey)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
            ( String
"mismatched or unsupported private key pair"
            , Bool
True
            , AlertDescription
InternalError )
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ (PubKey, PrivKey) -> HandshakeM ()
setPublicPrivateKeys (PubKey
pubkey, PrivKey
privkey)
    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 Context
ctx Group
grp =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Group -> Bool
isSupportedGroup Context
ctx Group
grp) forall a b. (a -> b) -> a -> b
$
        let msg :: String
msg = String
"unsupported (EC)DHE group: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Group
grp
         in forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 Context
ctx Group
grp = Group
grp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)