{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Client
( handshakeClient
, handshakeClientWith
, postHandshakeAuthClientWith
) where
import Network.TLS.Crypto
import Network.TLS.Context.Internal
import Network.TLS.Parameters
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Credentials
import Network.TLS.Packet hiding (getExtensions)
import Network.TLS.ErrT
import Network.TLS.Extension
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.State
import Network.TLS.Measurement
import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_)
import Network.TLS.Types
import Network.TLS.X509
import qualified Data.ByteString as B
import Data.X509 (ExtKeyUsageFlag(..))
import Control.Monad.State.Strict
import Control.Exception (SomeException, bracket)
import Network.TLS.Handshake.Certificate
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Control
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Random
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.Wire
handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()
handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()
handshakeClientWith ClientParams
cparams Context
ctx Handshake
HelloRequest = ClientParams -> Context -> IO ()
handshakeClient ClientParams
cparams Context
ctx
handshakeClientWith ClientParams
_ Context
_ Handshake
_ = forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unexpected handshake message received in handshakeClientWith", Bool
True, AlertDescription
HandshakeFailure)
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient ClientParams
cparams Context
ctx = do
let groups :: [Group]
groups = case ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams of
Maybe (ByteString, SessionData)
Nothing -> [Group]
groupsSupported
Just (ByteString
_, SessionData
sdata) -> case SessionData -> Maybe Group
sessionGroup SessionData
sdata of
Maybe Group
Nothing -> []
Just Group
grp -> Group
grp forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Group
grp) [Group]
groupsSupported
groupsSupported :: [Group]
groupsSupported = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshakeClient' ClientParams
cparams Context
ctx [Group]
groups forall a. Maybe a
Nothing
handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO ()
handshakeClient' :: ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshakeClient' ClientParams
cparams Context
ctx [Group]
groups Maybe (ClientRandom, Session, Version)
mparams = do
Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
ctx Measurement -> Measurement
incrementNbHandshakes
(ClientRandom
crand, Session
clientSession) <- IO (ClientRandom, Session)
generateClientHelloParams
(Bool
rtt0, [ExtensionID]
sentExtensions) <- Session -> ClientRandom -> IO (Bool, [ExtensionID])
sendClientHello Session
clientSession ClientRandom
crand
Session -> [ExtensionID] -> IO ()
recvServerHello Session
clientSession [ExtensionID]
sentExtensions
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\(ClientRandom
_, Session
_, Version
v) -> Version
v forall a. Eq a => a -> a -> Bool
== Version
ver) Maybe (ClientRandom, Session, Version)
mparams) 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
"version changed after hello retry", Bool
True, AlertDescription
IllegalParameter)
Bool
hrr <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
if Version
ver forall a. Eq a => a -> a -> Bool
== Version
TLS13 then
if Bool
hrr then case forall a. Int -> [a] -> [a]
drop Int
1 [Group]
groups of
[] -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"group is exhausted in the client side", Bool
True, AlertDescription
IllegalParameter)
[Group]
groups' -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (ClientRandom, Session, Version)
mparams) 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
"server sent too many hello retries", Bool
True, AlertDescription
UnexpectedMessage)
Maybe KeyShare
mks <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe KeyShare)
getTLS13KeyShare
case Maybe KeyShare
mks of
Just (KeyShareHRR Group
selectedGroup)
| Group
selectedGroup forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groups' -> do
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
HelloRetryRequest
Context -> IO ()
clearTxState Context
ctx
let cparams' :: ClientParams
cparams' = ClientParams
cparams { clientEarlyData :: Maybe ByteString
clientEarlyData = forall a. Maybe a
Nothing }
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshakeClient' ClientParams
cparams' Context
ctx [Group
selectedGroup] (forall a. a -> Maybe a
Just (ClientRandom
crand, Session
clientSession, Version
ver))
| Bool
otherwise -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server-selected group is not supported", Bool
True, AlertDescription
IllegalParameter)
Just KeyShare
_ -> forall a. HasCallStack => String -> a
error String
"handshakeClient': invalid KeyShare value"
Maybe KeyShare
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"key exchange not implemented in HRR, expected key_share extension", Bool
True, AlertDescription
HandshakeFailure)
else
ClientParams -> Context -> Maybe Group -> IO ()
handshakeClient13 ClientParams
cparams Context
ctx Maybe Group
groupToSend
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtt0 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
"server denied TLS 1.3 when connecting with early data", Bool
True, AlertDescription
HandshakeFailure)
Bool
sessionResuming <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
isSessionResuming
if Bool
sessionResuming
then Context -> Role -> IO ()
sendChangeCipherAndFinish Context
ctx Role
ClientRole
else do ClientParams -> Context -> IO ()
sendClientData ClientParams
cparams Context
ctx
Context -> Role -> IO ()
sendChangeCipherAndFinish Context
ctx Role
ClientRole
Context -> IO ()
recvChangeCipherAndFinish Context
ctx
Context -> IO ()
handshakeTerminate Context
ctx
where ciphers :: [Cipher]
ciphers = Supported -> [Cipher]
supportedCiphers forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
compressions :: [Compression]
compressions = Supported -> [Compression]
supportedCompressions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
highestVer :: Version
highestVer = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
tls13 :: Bool
tls13 = Version
highestVer forall a. Ord a => a -> a -> Bool
>= Version
TLS13
ems :: EMSMode
ems = Supported -> EMSMode
supportedExtendedMasterSec forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
groupToSend :: Maybe Group
groupToSend = forall a. [a] -> Maybe a
listToMaybe [Group]
groups
getExtensions :: Maybe (ByteString, b, CipherChoice, Word32)
-> Bool -> IO [Maybe ExtensionRaw]
getExtensions Maybe (ByteString, b, CipherChoice, Word32)
pskInfo Bool
rtt0 = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ IO (Maybe ExtensionRaw)
sniExtension
, IO (Maybe ExtensionRaw)
secureReneg
, IO (Maybe ExtensionRaw)
alpnExtension
, IO (Maybe ExtensionRaw)
emsExtension
, IO (Maybe ExtensionRaw)
groupExtension
, IO (Maybe ExtensionRaw)
ecPointExtension
, IO (Maybe ExtensionRaw)
signatureAlgExtension
, IO (Maybe ExtensionRaw)
versionExtension
, forall {m :: * -> *}. Monad m => Bool -> m (Maybe ExtensionRaw)
earlyDataExtension Bool
rtt0
, IO (Maybe ExtensionRaw)
keyshareExtension
, IO (Maybe ExtensionRaw)
cookieExtension
, IO (Maybe ExtensionRaw)
postHandshakeAuthExtension
, IO (Maybe ExtensionRaw)
pskExchangeModeExtension
, forall {m :: * -> *} {b}.
Monad m =>
Maybe (ByteString, b, CipherChoice, Word32)
-> m (Maybe ExtensionRaw)
preSharedKeyExtension Maybe (ByteString, b, CipherChoice, Word32)
pskInfo
]
toExtensionRaw :: Extension e => e -> ExtensionRaw
toExtensionRaw :: forall e. Extension e => e -> ExtensionRaw
toExtensionRaw e
ext = ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw (forall a. Extension a => a -> ExtensionID
extensionID e
ext) (forall a. Extension a => a -> ByteString
extensionEncode e
ext)
secureReneg :: IO (Maybe ExtensionRaw)
secureReneg =
if Supported -> Bool
supportedSecureRenegotiation forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
then forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Role -> TLSSt ByteString
getVerifiedData Role
ClientRole) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
vd -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
vd forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
alpnExtension :: IO (Maybe ExtensionRaw)
alpnExtension = do
Maybe [ByteString]
mprotos <- ClientHooks -> IO (Maybe [ByteString])
onSuggestALPN forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cparams
case Maybe [ByteString]
mprotos of
Maybe [ByteString]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just [ByteString]
protos -> do
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ [ByteString] -> TLSSt ()
setClientALPNSuggest [ByteString]
protos
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [ByteString] -> ApplicationLayerProtocolNegotiation
ApplicationLayerProtocolNegotiation [ByteString]
protos
emsExtension :: IO (Maybe ExtensionRaw)
emsExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if EMSMode
ems forall a. Eq a => a -> a -> Bool
== EMSMode
NoEMS Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> a -> Bool
>= Version
TLS13) (Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw ExtendedMasterSecret
ExtendedMasterSecret
sniExtension :: IO (Maybe ExtensionRaw)
sniExtension = if ClientParams -> Bool
clientUseServerNameIndication ClientParams
cparams
then do let sni :: String
sni = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ ClientParams -> (String, ByteString)
clientServerIdentification ClientParams
cparams
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ String -> TLSSt ()
setClientSNI String
sni
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [ServerNameType] -> ServerName
ServerName [String -> ServerNameType
ServerNameHostName String
sni]
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
groupExtension :: IO (Maybe ExtensionRaw)
groupExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [Group] -> NegotiatedGroups
NegotiatedGroups (Supported -> [Group]
supportedGroups forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)
ecPointExtension :: IO (Maybe ExtensionRaw)
ecPointExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [EcPointFormat] -> EcPointFormatsSupported
EcPointFormatsSupported [EcPointFormat
EcPointFormat_Uncompressed]
signatureAlgExtension :: IO (Maybe ExtensionRaw)
signatureAlgExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [HashAndSignatureAlgorithm] -> SignatureAlgorithms
SignatureAlgorithms forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ ClientParams -> Supported
clientSupported ClientParams
cparams
versionExtension :: IO (Maybe ExtensionRaw)
versionExtension
| Bool
tls13 = do
let vers :: [Version]
vers = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
>= Version
TLS10) forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [Version] -> SupportedVersions
SupportedVersionsClientHello [Version]
vers
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
keyshareExtension :: IO (Maybe ExtensionRaw)
keyshareExtension
| Bool
tls13 = case Maybe Group
groupToSend of
Maybe Group
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Group
grp -> do
(GroupPrivate
cpri, KeyShareEntry
ent) <- Context -> Group -> IO (GroupPrivate, KeyShareEntry)
makeClientKeyShare Context
ctx Group
grp
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ GroupPrivate -> HandshakeM ()
setGroupPrivate GroupPrivate
cpri
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [KeyShareEntry] -> KeyShare
KeyShareClientHello [KeyShareEntry
ent]
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
sessionAndCipherToResume13 :: Maybe (ByteString, SessionData, Cipher)
sessionAndCipherToResume13 = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
tls13
(ByteString
sid, SessionData
sdata) <- ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SessionData -> Version
sessionVersion SessionData
sdata forall a. Ord a => a -> a -> Bool
>= Version
TLS13)
Cipher
sCipher <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Cipher
c -> Cipher -> ExtensionID
cipherID Cipher
c forall a. Eq a => a -> a -> Bool
== SessionData -> ExtensionID
sessionCipher SessionData
sdata) [Cipher]
ciphers
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sid, SessionData
sdata, Cipher
sCipher)
getPskInfo :: IO (Maybe (ByteString, SessionData, CipherChoice, Word32))
getPskInfo =
case Maybe (ByteString, SessionData, Cipher)
sessionAndCipherToResume13 of
Maybe (ByteString, SessionData, Cipher)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (ByteString
sid, SessionData
sdata, Cipher
sCipher) -> do
let tinfo :: TLS13TicketInfo
tinfo = forall a. String -> Maybe a -> a
fromJust String
"sessionTicketInfo" forall a b. (a -> b) -> a -> b
$ SessionData -> Maybe TLS13TicketInfo
sessionTicketInfo SessionData
sdata
Word32
age <- TLS13TicketInfo -> IO Word32
getAge TLS13TicketInfo
tinfo
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Word32 -> TLS13TicketInfo -> Bool
isAgeValid Word32
age TLS13TicketInfo
tinfo
then forall a. a -> Maybe a
Just (ByteString
sid, SessionData
sdata, Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
sCipher, Word32 -> TLS13TicketInfo -> Word32
ageToObfuscatedAge Word32
age TLS13TicketInfo
tinfo)
else forall a. Maybe a
Nothing
preSharedKeyExtension :: Maybe (ByteString, b, CipherChoice, Word32)
-> m (Maybe ExtensionRaw)
preSharedKeyExtension Maybe (ByteString, b, CipherChoice, Word32)
pskInfo =
case Maybe (ByteString, b, CipherChoice, Word32)
pskInfo of
Maybe (ByteString, b, CipherChoice, Word32)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (ByteString
sid, b
_, CipherChoice
choice, Word32
obfAge) ->
let zero :: ByteString
zero = CipherChoice -> ByteString
cZero CipherChoice
choice
identity :: PskIdentity
identity = ByteString -> Word32 -> PskIdentity
PskIdentity ByteString
sid Word32
obfAge
offeredPsks :: PreSharedKey
offeredPsks = [PskIdentity] -> [ByteString] -> PreSharedKey
PreSharedKeyClientHello [PskIdentity
identity] [ByteString
zero]
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw PreSharedKey
offeredPsks
pskExchangeModeExtension :: IO (Maybe ExtensionRaw)
pskExchangeModeExtension
| Bool
tls13 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [PskKexMode] -> PskKeyExchangeModes
PskKeyExchangeModes [PskKexMode
PSK_DHE_KE]
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
earlyDataExtension :: Bool -> m (Maybe ExtensionRaw)
earlyDataExtension Bool
rtt0
| Bool
rtt0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (Maybe Word32 -> EarlyDataIndication
EarlyDataIndication forall a. Maybe a
Nothing)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
cookieExtension :: IO (Maybe ExtensionRaw)
cookieExtension = do
Maybe Cookie
mcookie <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Cookie)
getTLS13Cookie
case Maybe Cookie
mcookie of
Maybe Cookie
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Cookie
cookie -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw Cookie
cookie
postHandshakeAuthExtension :: IO (Maybe ExtensionRaw)
postHandshakeAuthExtension
| Context -> Bool
ctxQUICMode Context
ctx = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
tls13 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw PostHandshakeAuth
PostHandshakeAuth
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
adjustExtentions :: Maybe (a, SessionData, CipherChoice, d)
-> [ExtensionRaw] -> Handshake -> IO [ExtensionRaw]
adjustExtentions Maybe (a, SessionData, CipherChoice, d)
pskInfo [ExtensionRaw]
exts Handshake
ch =
case Maybe (a, SessionData, CipherChoice, d)
pskInfo of
Maybe (a, SessionData, CipherChoice, d)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionRaw]
exts
Just (a
_, SessionData
sdata, CipherChoice
choice, d
_) -> do
let psk :: ByteString
psk = SessionData -> ByteString
sessionSecret SessionData
sdata
earlySecret :: BaseSecret EarlySecret
earlySecret = CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice (forall a. a -> Maybe a
Just ByteString
psk)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ BaseSecret EarlySecret -> HandshakeM ()
setTLS13EarlySecret BaseSecret EarlySecret
earlySecret
let ech :: ByteString
ech = Handshake -> ByteString
encodeHandshake Handshake
ch
h :: Hash
h = CipherChoice -> Hash
cHash CipherChoice
choice
siz :: Int
siz = Hash -> Int
hashDigestSize Hash
h
ByteString
binder <- Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe ByteString
-> IO ByteString
makePSKBinder Context
ctx BaseSecret EarlySecret
earlySecret Hash
h (Int
siz forall a. Num a => a -> a -> a
+ Int
3) (forall a. a -> Maybe a
Just ByteString
ech)
let exts' :: [ExtensionRaw]
exts' = forall a. [a] -> [a]
init [ExtensionRaw]
exts forall a. [a] -> [a] -> [a]
++ [ExtensionRaw -> ExtensionRaw
adjust (forall a. [a] -> a
last [ExtensionRaw]
exts)]
adjust :: ExtensionRaw -> ExtensionRaw
adjust (ExtensionRaw ExtensionID
eid ByteString
withoutBinders) = ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
eid ByteString
withBinders
where
withBinders :: ByteString
withBinders = ByteString -> ByteString -> ByteString
replacePSKBinder ByteString
withoutBinders ByteString
binder
forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionRaw]
exts'
generateClientHelloParams :: IO (ClientRandom, Session)
generateClientHelloParams =
case Maybe (ClientRandom, Session, Version)
mparams of
Just (ClientRandom
crand, Session
clientSession, Version
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (ClientRandom
crand, Session
clientSession)
Maybe (ClientRandom, Session, Version)
Nothing -> do
ClientRandom
crand <- Context -> IO ClientRandom
clientRandom Context
ctx
let paramSession :: Session
paramSession = case ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams of
Maybe (ByteString, SessionData)
Nothing -> Maybe ByteString -> Session
Session forall a. Maybe a
Nothing
Just (ByteString
sid, SessionData
sdata)
| SessionData -> Version
sessionVersion SessionData
sdata forall a. Ord a => a -> a -> Bool
>= Version
TLS13 -> Maybe ByteString -> Session
Session forall a. Maybe a
Nothing
| EMSMode
ems forall a. Eq a => a -> a -> Bool
== EMSMode
RequireEMS Bool -> Bool -> Bool
&& Bool
noSessionEMS -> Maybe ByteString -> Session
Session forall a. Maybe a
Nothing
| Bool
otherwise -> Maybe ByteString -> Session
Session (forall a. a -> Maybe a
Just ByteString
sid)
where noSessionEMS :: Bool
noSessionEMS = SessionFlag
SessionEMS forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` SessionData -> [SessionFlag]
sessionFlags SessionData
sdata
if Bool
tls13 Bool -> Bool -> Bool
&& Session
paramSession forall a. Eq a => a -> a -> Bool
== Maybe ByteString -> Session
Session forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)
then do
Session
randomSession <- Context -> IO Session
newSession Context
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientRandom
crand, Session
randomSession)
else forall (m :: * -> *) a. Monad m => a -> m a
return (ClientRandom
crand, Session
paramSession)
sendClientHello :: Session -> ClientRandom -> IO (Bool, [ExtensionID])
sendClientHello Session
clientSession ClientRandom
crand = do
let ver :: Version
ver = if Bool
tls13 then Version
TLS12 else Version
highestVer
Bool
hrr <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hrr forall a b. (a -> b) -> a -> b
$ Context -> Version -> ClientRandom -> IO ()
startHandshake Context
ctx Version
ver ClientRandom
crand
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> TLSSt ()
setVersionIfUnset Version
highestVer
let cipherIds :: [ExtensionID]
cipherIds = forall a b. (a -> b) -> [a] -> [b]
map Cipher -> ExtensionID
cipherID [Cipher]
ciphers
compIds :: [CompressionID]
compIds = forall a b. (a -> b) -> [a] -> [b]
map Compression -> CompressionID
compressionID [Compression]
compressions
mkClientHello :: [ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
exts = Version
-> ClientRandom
-> Session
-> [ExtensionID]
-> [CompressionID]
-> [ExtensionRaw]
-> Maybe ByteString
-> Handshake
ClientHello Version
ver ClientRandom
crand Session
clientSession [ExtensionID]
cipherIds [CompressionID]
compIds [ExtensionRaw]
exts forall a. Maybe a
Nothing
Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo <- IO (Maybe (ByteString, SessionData, CipherChoice, Word32))
getPskInfo
let rtt0info :: Maybe (CipherChoice, ByteString)
rtt0info = Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {a} {d}. (a, SessionData, a, d) -> Maybe (a, ByteString)
get0RTTinfo
rtt0 :: Bool
rtt0 = forall a. Maybe a -> Bool
isJust Maybe (CipherChoice, ByteString)
rtt0info
[ExtensionRaw]
extensions0 <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}.
Maybe (ByteString, b, CipherChoice, Word32)
-> Bool -> IO [Maybe ExtensionRaw]
getExtensions Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo Bool
rtt0
let extensions1 :: [ExtensionRaw]
extensions1 = Shared -> [ExtensionRaw]
sharedHelloExtensions (ClientParams -> Shared
clientShared ClientParams
cparams) forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
extensions0
[ExtensionRaw]
extensions <- forall {a} {d}.
Maybe (a, SessionData, CipherChoice, d)
-> [ExtensionRaw] -> Handshake -> IO [ExtensionRaw]
adjustExtentions Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo [ExtensionRaw]
extensions1 forall a b. (a -> b) -> a -> b
$ [ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
extensions1
Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [[ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
extensions]
Maybe EarlySecretInfo
mEarlySecInfo <- case Maybe (CipherChoice, ByteString)
rtt0info of
Maybe (CipherChoice, ByteString)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (CipherChoice, ByteString)
info -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CipherChoice, ByteString) -> IO EarlySecretInfo
send0RTT (CipherChoice, ByteString)
info
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hrr forall a b. (a -> b) -> a -> b
$ Context -> ClientState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ Maybe EarlySecretInfo -> ClientState
SendClientHello Maybe EarlySecretInfo
mEarlySecInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
rtt0, forall a b. (a -> b) -> [a] -> [b]
map (\(ExtensionRaw ExtensionID
i ByteString
_) -> ExtensionID
i) [ExtensionRaw]
extensions)
get0RTTinfo :: (a, SessionData, a, d) -> Maybe (a, ByteString)
get0RTTinfo (a
_, SessionData
sdata, a
choice, d
_) = do
ByteString
earlyData <- ClientParams -> Maybe ByteString
clientEarlyData ClientParams
cparams
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
B.length ByteString
earlyData forall a. Ord a => a -> a -> Bool
<= SessionData -> Int
sessionMaxEarlyDataSize SessionData
sdata)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
choice, ByteString
earlyData)
send0RTT :: (CipherChoice, ByteString) -> IO EarlySecretInfo
send0RTT (CipherChoice
choice, ByteString
earlyData) = do
let usedCipher :: Cipher
usedCipher = CipherChoice -> Cipher
cCipher CipherChoice
choice
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
Just BaseSecret EarlySecret
earlySecret <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe (BaseSecret EarlySecret))
getTLS13EarlySecret
SecretPair EarlySecret
earlyKey <- Context
-> CipherChoice
-> Either ByteString (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret Context
ctx CipherChoice
choice (forall a b. b -> Either a b
Right BaseSecret EarlySecret
earlySecret) Bool
False
let clientEarlySecret :: ClientTrafficSecret EarlySecret
clientEarlySecret = forall a. SecretPair a -> ClientTrafficSecret a
pairClient SecretPair EarlySecret
earlyKey
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Bool
ctxQUICMode Context
ctx) forall a b. (a -> b) -> a -> b
$ do
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret
let len :: Maybe Int
len = Context -> Maybe Int
ctxFragmentSize Context
ctx
forall (m :: * -> *) a.
Monad m =>
Maybe Int -> (ByteString -> m a) -> ByteString -> m ()
mapChunks_ Maybe Int
len (Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet13
AppData13) ByteString
earlyData
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Sent
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cipher -> ClientTrafficSecret EarlySecret -> EarlySecretInfo
EarlySecretInfo Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret
recvServerHello :: Session -> [ExtensionID] -> IO ()
recvServerHello Session
clientSession [ExtensionID]
sentExts = Context -> RecvState IO -> IO ()
runRecvState Context
ctx RecvState IO
recvState
where recvState :: RecvState IO
recvState = forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStateNext forall a b. (a -> b) -> a -> b
$ \Packet
p ->
case Packet
p of
Handshake [Handshake]
hs -> Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx (forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake forall a b. (a -> b) -> a -> b
$ Context
-> ClientParams
-> Session
-> [ExtensionID]
-> Handshake
-> IO (RecvState IO)
onServerHello Context
ctx ClientParams
cparams Session
clientSession [ExtensionID]
sentExts) [Handshake]
hs
Alert [(AlertLevel, AlertDescription)]
a ->
case [(AlertLevel, AlertDescription)]
a of
[(AlertLevel
AlertLevel_Warning, AlertDescription
UnrecognizedName)] ->
if ClientParams -> Bool
clientUseServerNameIndication ClientParams
cparams
then forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
recvState
else forall {m :: * -> *} {a} {a}. (MonadIO m, Show a) => a -> m a
throwAlert [(AlertLevel, AlertDescription)]
a
[(AlertLevel, AlertDescription)]
_ -> forall {m :: * -> *} {a} {a}. (MonadIO m, Show a) => a -> m a
throwAlert [(AlertLevel, AlertDescription)]
a
Packet
_ -> 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
"handshake")
throwAlert :: a -> m a
throwAlert a
a = forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"expecting server hello, got alert : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a, Bool
True, AlertDescription
HandshakeFailure)
storePrivInfoClient :: Context
-> [CertificateType]
-> Credential
-> IO ()
storePrivInfoClient :: Context -> [CertificateType] -> Credential -> IO ()
storePrivInfoClient Context
ctx [CertificateType]
cTypes (CertificateChain
cc, PrivKey
privkey) = do
PubKey
pubkey <- forall (m :: * -> *).
MonadIO m =>
Context -> CertificateChain -> PrivKey -> m PubKey
storePrivInfo Context
ctx CertificateChain
cc PrivKey
privkey
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey -> [CertificateType] -> Bool
certificateCompatible PubKey
pubkey [CertificateType]
cTypes) 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
( PubKey -> String
pubkeyType PubKey
pubkey forall a. [a] -> [a] -> [a]
++ String
" credential does not match allowed certificate types"
, Bool
True
, AlertDescription
InternalError )
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey
pubkey PubKey -> Version -> Bool
`versionCompatible` Version
ver) 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
( PubKey -> String
pubkeyType PubKey
pubkey forall a. [a] -> [a] -> [a]
++ String
" credential is not supported at version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
ver
, Bool
True
, AlertDescription
InternalError )
clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx =
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertReqCBdata)
getCertReqCBdata forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe CertReqCBdata
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just CertReqCBdata
cbdata -> do
let callback :: OnCertificateRequest
callback = ClientHooks -> OnCertificateRequest
onCertificateRequest forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cparams
Maybe Credential
chain <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ OnCertificateRequest
callback CertReqCBdata
cbdata forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException`
forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
"certificate request callback failed"
case Maybe Credential
chain of
Maybe Credential
Nothing
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
Just (CertificateChain [], PrivKey
_)
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
Just cred :: Credential
cred@(CertificateChain
cc, PrivKey
_)
-> do
let ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
_, [DistinguishedName]
_) = CertReqCBdata
cbdata
Context -> [CertificateType] -> Credential -> IO ()
storePrivInfoClient Context
ctx [CertificateType]
cTypes Credential
cred
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just CertificateChain
cc
getLocalHashSigAlg :: Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg :: Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
isCompatible [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey = do
(Just ([CertificateType]
_, Just [HashAndSignatureAlgorithm]
hashSigs, [DistinguishedName]
_)) <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertReqCBdata)
getCertReqCBdata
let want :: HashAndSignatureAlgorithm -> Bool
want = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PubKey -> HashAndSignatureAlgorithm -> Bool
isCompatible PubKey
pubKey
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [HashAndSignatureAlgorithm]
hashSigs
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find HashAndSignatureAlgorithm -> Bool
want [HashAndSignatureAlgorithm]
cHashSigs of
Just HashAndSignatureAlgorithm
best -> forall (m :: * -> *) a. Monad m => a -> m a
return HashAndSignatureAlgorithm
best
Maybe HashAndSignatureAlgorithm
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
( PubKey -> String
keyerr PubKey
pubKey
, Bool
True
, AlertDescription
HandshakeFailure
)
where
keyerr :: PubKey -> String
keyerr PubKey
k = String
"no " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
k forall a. [a] -> [a] -> [a]
++ String
" hash algorithm in common with the server"
supportedCtypes :: [HashAndSignatureAlgorithm]
-> [CertificateType]
supportedCtypes :: [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes [HashAndSignatureAlgorithm]
hashAlgs =
forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HashAndSignatureAlgorithm -> [CertificateType] -> [CertificateType]
ctfilter [] [HashAndSignatureAlgorithm]
hashAlgs
where
ctfilter :: HashAndSignatureAlgorithm -> [CertificateType] -> [CertificateType]
ctfilter HashAndSignatureAlgorithm
x [CertificateType]
acc = case HashAndSignatureAlgorithm -> Maybe CertificateType
hashSigToCertType HashAndSignatureAlgorithm
x of
Just CertificateType
cType | CertificateType
cType forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType
-> CertificateType
cType forall a. a -> [a] -> [a]
: [CertificateType]
acc
Maybe CertificateType
_ -> [CertificateType]
acc
clientSupportedCtypes :: Context
-> [CertificateType]
clientSupportedCtypes :: Context -> [CertificateType]
clientSupportedCtypes Context
ctx =
[HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
sigAlgsToCertTypes :: Context
-> [HashAndSignatureAlgorithm]
-> [CertificateType]
sigAlgsToCertTypes :: Context -> [HashAndSignatureAlgorithm] -> [CertificateType]
sigAlgsToCertTypes Context
ctx [HashAndSignatureAlgorithm]
hashSigs =
forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes [HashAndSignatureAlgorithm]
hashSigs) forall a b. (a -> b) -> a -> b
$ Context -> [CertificateType]
clientSupportedCtypes Context
ctx
sendClientData :: ClientParams -> Context -> IO ()
sendClientData :: ClientParams -> Context -> IO ()
sendClientData ClientParams
cparams Context
ctx = IO ()
sendCertificate forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
sendClientKeyXchg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
sendCertificateVerify
where
sendCertificate :: IO ()
sendCertificate = do
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setClientCertSent Bool
False
ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe CertificateChain
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just cc :: CertificateChain
cc@(CertificateChain [SignedExact Certificate]
certs) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedExact Certificate]
certs) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setClientCertSent Bool
True
Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [CertificateChain -> Handshake
Certificates CertificateChain
cc]
sendClientKeyXchg :: IO ()
sendClientKeyXchg = do
Cipher
cipher <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
(ClientKeyXchgAlgorithmData
ckx, HandshakeM ByteString
setMasterSec) <- case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
CipherKeyExchangeType
CipherKeyExchange_RSA -> do
Version
clientVersion <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HandshakeState -> Version
hstClientVersion
(Version
xver, ByteString
prerand) <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TLSSt Version
getVersion forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TLSSt ByteString
genRandom Int
46
let premaster :: ByteString
premaster = Version -> ByteString -> ByteString
encodePreMasterSecret Version
clientVersion ByteString
prerand
setMasterSec :: HandshakeM ByteString
setMasterSec = forall preMaster.
ByteArrayAccess preMaster =>
Version -> Role -> preMaster -> HandshakeM ByteString
setMasterSecretFromPre Version
xver Role
ClientRole ByteString
premaster
ByteString
encryptedPreMaster <- do
ByteString
e <- Context -> ByteString -> IO ByteString
encryptRSA Context
ctx ByteString
premaster
let extra :: ByteString
extra = if Version
xver forall a. Ord a => a -> a -> Bool
< Version
TLS10
then ByteString
B.empty
else ExtensionID -> ByteString
encodeWord16 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
extra ByteString -> ByteString -> ByteString
`B.append` ByteString
e
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ClientKeyXchgAlgorithmData
CKX_RSA ByteString
encryptedPreMaster, HandshakeM ByteString
setMasterSec)
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_DHE
CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_DHE
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE
CipherKeyExchangeType
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"client key exchange unsupported type", Bool
True, AlertDescription
HandshakeFailure)
Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [ClientKeyXchgAlgorithmData -> Handshake
ClientKeyXchg ClientKeyXchgAlgorithmData
ckx]
ByteString
masterSecret <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ByteString
setMasterSec
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MasterSecret
MasterSecret ByteString
masterSecret)
where getCKX_DHE :: IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_DHE = do
Version
xver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
ServerDHParams
serverParams <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerDHParams
getServerDHParams
let params :: DHParams
params = ServerDHParams -> DHParams
serverDHParamsToParams ServerDHParams
serverParams
ffGroup :: Maybe Group
ffGroup = DHParams -> Maybe Group
findFiniteFieldGroup DHParams
params
srvpub :: DHPublic
srvpub = ServerDHParams -> DHPublic
serverDHParamsToPublic ServerDHParams
serverParams
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Context -> Group -> Bool
isSupportedGroup Context
ctx) Maybe Group
ffGroup) forall a b. (a -> b) -> a -> b
$ do
GroupUsage
groupUsage <- ClientHooks -> DHParams -> DHPublic -> IO GroupUsage
onCustomFFDHEGroup (ClientParams -> ClientHooks
clientHooks ClientParams
cparams) DHParams
params DHPublic
srvpub forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException`
forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
"custom group callback failed"
case GroupUsage
groupUsage of
GroupUsage
GroupUsageInsecure -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"FFDHE group is not secure enough", Bool
True, AlertDescription
InsufficientSecurity)
GroupUsageUnsupported String
reason -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unsupported FFDHE group: " forall a. [a] -> [a] -> [a]
++ String
reason, Bool
True, AlertDescription
HandshakeFailure)
GroupUsage
GroupUsageInvalidPublic -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server public key", Bool
True, AlertDescription
IllegalParameter)
GroupUsage
GroupUsageValid -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(DHPublic
clientDHPub, DHKey
premaster) <-
case Maybe Group
ffGroup of
Maybe Group
Nothing -> do
(DHPrivate
clientDHPriv, DHPublic
clientDHPub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
generateDHE Context
ctx DHParams
params
let premaster :: DHKey
premaster = DHParams -> DHPrivate -> DHPublic -> DHKey
dhGetShared DHParams
params DHPrivate
clientDHPriv DHPublic
srvpub
forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic
clientDHPub, DHKey
premaster)
Just Group
grp -> do
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setNegotiatedGroup Group
grp
Maybe (DHPublic, DHKey)
dhePair <- Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey))
generateFFDHEShared Context
ctx Group
grp DHPublic
srvpub
case Maybe (DHPublic, DHKey)
dhePair of
Maybe (DHPublic, DHKey)
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Group
grp forall a. [a] -> [a] -> [a]
++ String
" public key", Bool
True, AlertDescription
IllegalParameter)
Just (DHPublic, DHKey)
pair -> forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic, DHKey)
pair
let setMasterSec :: HandshakeM ByteString
setMasterSec = forall preMaster.
ByteArrayAccess preMaster =>
Version -> Role -> preMaster -> HandshakeM ByteString
setMasterSecretFromPre Version
xver Role
ClientRole DHKey
premaster
forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic -> ClientKeyXchgAlgorithmData
CKX_DH DHPublic
clientDHPub, HandshakeM ByteString
setMasterSec)
getCKX_ECDHE :: IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE = do
ServerECDHParams Group
grp GroupPublic
srvpub <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerECDHParams
getServerECDHParams
Context -> Group -> IO ()
checkSupportedGroup Context
ctx Group
grp
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setNegotiatedGroup Group
grp
Maybe (GroupPublic, GroupKey)
ecdhePair <- Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))
generateECDHEShared Context
ctx GroupPublic
srvpub
case Maybe (GroupPublic, GroupKey)
ecdhePair of
Maybe (GroupPublic, GroupKey)
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Group
grp forall a. [a] -> [a] -> [a]
++ String
" public key", Bool
True, AlertDescription
IllegalParameter)
Just (GroupPublic
clipub, GroupKey
premaster) -> do
Version
xver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
let setMasterSec :: HandshakeM ByteString
setMasterSec = forall preMaster.
ByteArrayAccess preMaster =>
Version -> Role -> preMaster -> HandshakeM ByteString
setMasterSecretFromPre Version
xver Role
ClientRole GroupKey
premaster
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ClientKeyXchgAlgorithmData
CKX_ECDH forall a b. (a -> b) -> a -> b
$ GroupPublic -> ByteString
encodeGroupPublic GroupPublic
clipub, HandshakeM ByteString
setMasterSec)
sendCertificateVerify :: IO ()
sendCertificateVerify = do
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
Bool
certSent <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getClientCertSent
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
certSent forall a b. (a -> b) -> a -> b
$ do
PubKey
pubKey <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
Maybe HashAndSignatureAlgorithm
mhashSig <- case Version
ver of
Version
TLS12 ->
let cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
in forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
signatureCompatible [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey
Version
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
ByteString
msgs <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandshakeM [ByteString]
getHandshakeMessages
DigitallySigned
sigDig <- Context
-> Version
-> PubKey
-> Maybe HashAndSignatureAlgorithm
-> ByteString
-> IO DigitallySigned
createCertificateVerify Context
ctx Version
ver PubKey
pubKey Maybe HashAndSignatureAlgorithm
mhashSig ByteString
msgs
Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [DigitallySigned -> Handshake
CertVerify DigitallySigned
sigDig]
processServerExtension :: ExtensionRaw -> TLSSt ()
processServerExtension :: ExtensionRaw -> TLSSt ()
processServerExtension (ExtensionRaw ExtensionID
extID ByteString
content)
| ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_SecureRenegotiation = do
ByteString
cv <- Role -> TLSSt ByteString
getVerifiedData Role
ClientRole
ByteString
sv <- Role -> TLSSt ByteString
getVerifiedData Role
ServerRole
let bs :: ByteString
bs = forall a. Extension a => a -> ByteString
extensionEncode (ByteString -> Maybe ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
cv forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
sv)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
bs ByteString -> ByteString -> Bool
`bytesEq` ByteString
content) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server secure renegotiation data not matching", Bool
True, AlertDescription
HandshakeFailure)
| ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_SupportedVersions = case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTServerHello ByteString
content of
Just (SupportedVersionsServerHello Version
ver) -> Version -> TLSSt ()
setVersion Version
ver
Maybe SupportedVersions
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_KeyShare = do
Bool
hrr <- TLSSt Bool
getTLS13HRR
let msgt :: MessageType
msgt = if Bool
hrr then MessageType
MsgTHelloRetryRequest else MessageType
MsgTServerHello
Maybe KeyShare -> TLSSt ()
setTLS13KeyShare forall a b. (a -> b) -> a -> b
$ forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
msgt ByteString
content
| ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_PreSharedKey =
Maybe PreSharedKey -> TLSSt ()
setTLS13PreSharedKey forall a b. (a -> b) -> a -> b
$ forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTServerHello ByteString
content
processServerExtension ExtensionRaw
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
throwMiscErrorOnException :: String -> SomeException -> IO a
throwMiscErrorOnException :: forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
msg SomeException
e =
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Misc forall a b. (a -> b) -> a -> b
$ String
msg forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e
onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO)
onServerHello :: Context
-> ClientParams
-> Session
-> [ExtensionID]
-> Handshake
-> IO (RecvState IO)
onServerHello Context
ctx ClientParams
cparams Session
clientSession [ExtensionID]
sentExts (ServerHello Version
rver ServerRandom
serverRan Session
serverSession ExtensionID
cipher CompressionID
compression [ExtensionRaw]
exts) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
rver forall a. Eq a => a -> a -> Bool
== Version
SSL2) 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
"SSL2 is not supported", Bool
True, AlertDescription
ProtocolVersion)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
rver forall a. Eq a => a -> a -> Bool
== Version
SSL3) 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
"SSL3 is not supported", Bool
True, AlertDescription
ProtocolVersion)
Cipher
cipherAlg <- case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) ExtensionID
cipher forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> ExtensionID
cipherID) (Supported -> [Cipher]
supportedCiphers forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
Maybe Cipher
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server choose unknown cipher", Bool
True, AlertDescription
IllegalParameter)
Just Cipher
alg -> forall (m :: * -> *) a. Monad m => a -> m a
return Cipher
alg
Compression
compressAlg <- case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) CompressionID
compression forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compression -> CompressionID
compressionID) (Supported -> [Compression]
supportedCompressions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
Maybe Compression
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server choose unknown compression", Bool
True, AlertDescription
IllegalParameter)
Just Compression
alg -> forall (m :: * -> *) a. Monad m => a -> m a
return Compression
alg
let checkExt :: ExtensionRaw -> Bool
checkExt (ExtensionRaw ExtensionID
i ByteString
_)
| ExtensionID
i forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_Cookie = Bool
False
| Bool
otherwise = ExtensionID
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ExtensionID]
sentExts
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ExtensionRaw -> Bool
checkExt [ExtensionRaw]
exts) 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
"spurious extensions received", Bool
True, AlertDescription
UnsupportedExtension)
let resumingSession :: Maybe SessionData
resumingSession =
case ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams of
Just (ByteString
sessionId, SessionData
sessionData) -> if Session
serverSession forall a. Eq a => a -> a -> Bool
== Maybe ByteString -> Session
Session (forall a. a -> Maybe a
Just ByteString
sessionId) then forall a. a -> Maybe a
Just SessionData
sessionData else forall a. Maybe a
Nothing
Maybe (ByteString, SessionData)
Nothing -> forall a. Maybe a
Nothing
isHRR :: Bool
isHRR = ServerRandom -> Bool
isHelloRetryRequest ServerRandom
serverRan
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
Bool -> TLSSt ()
setTLS13HRR Bool
isHRR
Maybe Cookie -> TLSSt ()
setTLS13Cookie (forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isHRR forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_Cookie [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTServerHello)
Session -> Bool -> TLSSt ()
setSession Session
serverSession (forall a. Maybe a -> Bool
isJust Maybe SessionData
resumingSession)
Version -> TLSSt ()
setVersion Version
rver
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ExtensionRaw -> TLSSt ()
processServerExtension [ExtensionRaw]
exts
Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
MsgTServerHello [ExtensionRaw]
exts
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version -> [Version] -> ServerRandom -> Bool
isDowngraded Version
ver (Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ ClientParams -> Supported
clientSupported ClientParams
cparams) ServerRandom
serverRan) 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
"version downgrade detected", Bool
True, AlertDescription
IllegalParameter)
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
== Version
ver) (Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
Maybe Version
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
ver forall a. [a] -> [a] -> [a]
++ String
" is not supported", Bool
True, AlertDescription
ProtocolVersion)
Just Version
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
if Version
ver forall a. Ord a => a -> a -> Bool
> Version
TLS12 then do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Session
serverSession forall a. Eq a => a -> a -> Bool
/= Session
clientSession) 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 mismatched legacy session", Bool
True, AlertDescription
IllegalParameter)
Established
established <- Context -> IO Established
ctxEstablished Context
ctx
Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established forall a. Eq a => a -> a -> Bool
== Established
Established Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof) 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
"renegotiation to TLS 1.3 or later is not allowed", Bool
True, AlertDescription
ProtocolVersion)
forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression CompressionID
compression
forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
failOnEitherError forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Cipher -> HandshakeM (Either TLSError ())
setHelloParameters13 Cipher
cipherAlg
forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). RecvState m
RecvStateDone
else do
Bool
ems <- forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMasterSec Context
ctx Version
ver MessageType
MsgTServerHello [ExtensionRaw]
exts
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> ServerRandom -> Cipher -> Compression -> HandshakeM ()
setServerHelloParameters Version
rver ServerRandom
serverRan Cipher
cipherAlg Compression
compressAlg
case Maybe SessionData
resumingSession of
Maybe SessionData
Nothing -> 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 (ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate ClientParams
cparams Context
ctx)
Just SessionData
sessionData -> do
let emsSession :: Bool
emsSession = SessionFlag
SessionEMS forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SessionData -> [SessionFlag]
sessionFlags SessionData
sessionData
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ems forall a. Eq a => a -> a -> Bool
/= Bool
emsSession) forall a b. (a -> b) -> a -> b
$
let err :: String
err = String
"server resumes a session which is not EMS consistent"
in 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)
let masterSecret :: ByteString
masterSecret = SessionData -> ByteString
sessionSecret SessionData
sessionData
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> Role -> ByteString -> HandshakeM ()
setMasterSecret Version
rver Role
ClientRole ByteString
masterSecret
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MasterSecret
MasterSecret ByteString
masterSecret)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStateNext Packet -> IO (RecvState IO)
expectChangeCipher
onServerHello Context
_ ClientParams
_ Session
_ [ExtensionID]
_ 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
"server hello")
processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate ClientParams
cparams Context
ctx (Certificates CertificateChain
certs) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs) 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
"server certificate missing", Bool
True, AlertDescription
DecodeError)
forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx (Hooks -> CertificateChain -> IO ()
`hookRecvCertificates` CertificateChain
certs)
CertificateUsage
usage <- forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([FailedReason] -> CertificateUsage
wrapCertificateChecks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FailedReason]
checkCert) SomeException -> IO CertificateUsage
rejectOnException
case CertificateUsage
usage of
CertificateUsage
CertificateUsageAccept -> IO ()
checkLeafCertificateKeyUsage
CertificateUsageReject CertificateRejectReason
reason -> forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
certificateRejected CertificateRejectReason
reason
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 (Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange Context
ctx)
where shared :: Shared
shared = ClientParams -> Shared
clientShared ClientParams
cparams
checkCert :: IO [FailedReason]
checkCert = ClientHooks -> OnServerCertificate
onServerCertificate (ClientParams -> ClientHooks
clientHooks ClientParams
cparams) (Shared -> CertificateStore
sharedCAStore Shared
shared)
(Shared -> ValidationCache
sharedValidationCache Shared
shared)
(ClientParams -> (String, ByteString)
clientServerIdentification ClientParams
cparams)
CertificateChain
certs
checkLeafCertificateKeyUsage :: IO ()
checkLeafCertificateKeyUsage = do
Cipher
cipher <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
case Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage Cipher
cipher of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[ExtKeyUsageFlag]
flags -> forall (m :: * -> *).
MonadIO m =>
[ExtKeyUsageFlag] -> CertificateChain -> m ()
verifyLeafKeyUsage [ExtKeyUsageFlag]
flags CertificateChain
certs
processCertificate ClientParams
_ Context
ctx Handshake
p = Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange Context
ctx Handshake
p
expectChangeCipher :: Packet -> IO (RecvState IO)
expectChangeCipher :: Packet -> IO (RecvState IO)
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 Handshake -> IO (RecvState IO)
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 -> IO (RecvState IO)
expectFinish :: Handshake -> IO (RecvState IO)
expectFinish (Finished ByteString
_) = 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")
processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange Context
ctx (ServerKeyXchg ServerKeyXchgAlgorithmData
origSkx) = do
Cipher
cipher <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
origSkx
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 (Context -> Handshake -> IO (RecvState IO)
processCertificateRequest Context
ctx)
where processWithCipher :: Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
skx =
case (Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher, ServerKeyXchgAlgorithmData
skx) of
(CipherKeyExchangeType
CipherKeyExchange_DHE_RSA, SKX_DHE_RSA ServerDHParams
dhparams DigitallySigned
signature) ->
ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_RSA
(CipherKeyExchangeType
CipherKeyExchange_DHE_DSS, SKX_DHE_DSS ServerDHParams
dhparams DigitallySigned
signature) ->
ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_DSS
(CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ServerECDHParams
ecdhparams DigitallySigned
signature) ->
ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_RSA
(CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ServerECDHParams
ecdhparams DigitallySigned
signature) ->
ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_ECDSA
(CipherKeyExchangeType
cke, SKX_Unparsed ByteString
bytes) -> do
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
case Version
-> CipherKeyExchangeType
-> ByteString
-> Either TLSError ServerKeyXchgAlgorithmData
decodeReallyServerKeyXchgAlgorithmData Version
ver CipherKeyExchangeType
cke ByteString
bytes of
Left TLSError
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unknown server key exchange received, expecting: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CipherKeyExchangeType
cke, Bool
True, AlertDescription
HandshakeFailure)
Right ServerKeyXchgAlgorithmData
realSkx -> Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
realSkx
(CipherKeyExchangeType
c,ServerKeyXchgAlgorithmData
_) -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unknown server key exchange received, expecting: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CipherKeyExchangeType
c, Bool
True, AlertDescription
HandshakeFailure)
doDHESignature :: ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
kxsAlg = do
PubKey
publicKey <- KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg
Bool
verified <- Context -> ServerDHParams -> PubKey -> DigitallySigned -> IO Bool
digitallySignDHParamsVerify Context
ctx ServerDHParams
dhparams PubKey
publicKey DigitallySigned
signature
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError (String
"bad " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey forall a. [a] -> [a] -> [a]
++ String
" signature for dhparams " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ServerDHParams
dhparams)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerDHParams -> HandshakeM ()
setServerDHParams ServerDHParams
dhparams
doECDHESignature :: ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
kxsAlg = do
PubKey
publicKey <- KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg
Bool
verified <- Context -> ServerECDHParams -> PubKey -> DigitallySigned -> IO Bool
digitallySignECDHParamsVerify Context
ctx ServerECDHParams
ecdhparams PubKey
publicKey DigitallySigned
signature
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError (String
"bad " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey forall a. [a] -> [a] -> [a]
++ String
" signature for ecdhparams")
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> HandshakeM ()
setServerECDHParams ServerECDHParams
ecdhparams
getSignaturePublicKey :: KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg = do
PubKey
publicKey <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM PubKey
getRemotePublicKey
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyExchangeSignatureAlg -> PubKey -> Bool
isKeyExchangeSignatureKey KeyExchangeSignatureAlg
kxsAlg PubKey
publicKey) 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
"server public key algorithm is incompatible with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show KeyExchangeSignatureAlg
kxsAlg, Bool
True, AlertDescription
HandshakeFailure)
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey
publicKey PubKey -> Version -> Bool
`versionCompatible` Version
ver) 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 (forall a. Show a => a -> String
show Version
ver forall a. [a] -> [a] -> [a]
++ String
" has no support for " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey, Bool
True, AlertDescription
IllegalParameter)
let groups :: [Group]
groups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Group -> Bool) -> PubKey -> Bool
satisfiesEcPredicate (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groups) PubKey
publicKey) 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
"server public key has unsupported elliptic curve", Bool
True, AlertDescription
IllegalParameter)
forall (m :: * -> *) a. Monad m => a -> m a
return PubKey
publicKey
processServerKeyExchange Context
ctx Handshake
p = Context -> Handshake -> IO (RecvState IO)
processCertificateRequest Context
ctx Handshake
p
processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
processCertificateRequest Context
ctx (CertRequest [CertificateType]
cTypesSent Maybe [HashAndSignatureAlgorithm]
sigAlgs [DistinguishedName]
dNames) = do
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver forall a. Eq a => a -> a -> Bool
== Version
TLS12 Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe [HashAndSignatureAlgorithm]
sigAlgs) 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
"missing TLS 1.2 certificate request signature algorithms"
, Bool
True
, AlertDescription
InternalError
)
let cTypes :: [CertificateType]
cTypes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType) [CertificateType]
cTypesSent
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
sigAlgs, [DistinguishedName]
dNames)
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 :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
ctx)
processCertificateRequest Context
ctx Handshake
p = do
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata forall a. Maybe a
Nothing
forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
ctx Handshake
p
processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
processServerHelloDone :: forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
_ Handshake
ServerHelloDone = forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). RecvState m
RecvStateDone
processServerHelloDone Context
_ 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
"server hello data")
requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage Cipher
cipher =
case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
CipherKeyExchangeType
CipherKeyExchange_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> []
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> [ ExtKeyUsageFlag
KeyUsage_digitalSignature ]
CipherKeyExchangeType
CipherKeyExchange_DH_DSS -> [ ExtKeyUsageFlag
KeyUsage_keyAgreement ]
CipherKeyExchangeType
CipherKeyExchange_DH_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_ECDH_ECDSA -> [ ExtKeyUsageFlag
KeyUsage_keyAgreement ]
CipherKeyExchangeType
CipherKeyExchange_ECDH_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> [ ExtKeyUsageFlag
KeyUsage_digitalSignature ]
CipherKeyExchangeType
CipherKeyExchange_TLS13 -> [ ExtKeyUsageFlag
KeyUsage_digitalSignature ]
where rsaCompatibility :: [ExtKeyUsageFlag]
rsaCompatibility = [ ExtKeyUsageFlag
KeyUsage_digitalSignature
, ExtKeyUsageFlag
KeyUsage_keyEncipherment
, ExtKeyUsageFlag
KeyUsage_keyAgreement
]
handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO ()
handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO ()
handshakeClient13 ClientParams
cparams Context
ctx Maybe Group
groupSent = do
CipherChoice
choice <- Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' ClientParams
cparams Context
ctx Maybe Group
groupSent CipherChoice
choice
handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' ClientParams
cparams Context
ctx Maybe Group
groupSent CipherChoice
choice = do
(Cipher
_, SecretTriple HandshakeSecret
hkey, Bool
resuming) <- IO (Cipher, SecretTriple HandshakeSecret, Bool)
switchToHandshakeSecret
let handshakeSecret :: BaseSecret HandshakeSecret
handshakeSecret = forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple HandshakeSecret
hkey
clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
clientHandshakeSecret = forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple HandshakeSecret
hkey
serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
serverHandshakeSecret = forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple HandshakeSecret
hkey
handSecInfo :: HandshakeSecretInfo
handSecInfo = Cipher -> TrafficSecrets HandshakeSecret -> HandshakeSecretInfo
HandshakeSecretInfo Cipher
usedCipher (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret,ServerTrafficSecret HandshakeSecret
serverHandshakeSecret)
Context -> ClientState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ HandshakeSecretInfo -> ClientState
RecvServerHello HandshakeSecretInfo
handSecInfo
(Bool
rtt0accepted,[ExtensionRaw]
eexts) <- forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 forall a b. (a -> b) -> a -> b
$ do
(Bool, [ExtensionRaw])
accext <- forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> m (Bool, [ExtensionRaw])
expectEncryptedExtensions
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
resuming forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> RecvHandshake13M m ()
expectCertRequest
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
MonadIO m =>
ServerTrafficSecret a -> ByteString -> Handshake13 -> m ()
expectFinished ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, [ExtensionRaw])
accext
ByteString
hChSf <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Bool
ctxQUICMode Context
ctx) forall a b. (a -> b) -> a -> b
$
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
rtt0accepted Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)) forall a b. (a -> b) -> a -> b
$
Context -> Packet13 -> IO ()
sendPacket13 Context
ctx ([Handshake13] -> Packet13
Handshake13 [Handshake13
EndOfEarlyData13])
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
SecretTriple ApplicationSecret
appKey <- BaseSecret HandshakeSecret
-> ByteString -> IO (SecretTriple ApplicationSecret)
switchToApplicationSecret BaseSecret HandshakeSecret
handshakeSecret ByteString
hChSf
let applicationSecret :: BaseSecret ApplicationSecret
applicationSecret = forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple ApplicationSecret
appKey
BaseSecret ApplicationSecret -> IO ()
setResumptionSecret BaseSecret ApplicationSecret
applicationSecret
let appSecInfo :: ApplicationSecretInfo
appSecInfo = TrafficSecrets ApplicationSecret -> ApplicationSecretInfo
ApplicationSecretInfo (forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey, forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey)
Context -> ClientState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ [ExtensionRaw] -> ApplicationSecretInfo -> ClientState
SendClientFinished [ExtensionRaw]
eexts ApplicationSecretInfo
appSecInfo
Context -> IO ()
handshakeTerminate13 Context
ctx
where
usedCipher :: Cipher
usedCipher = CipherChoice -> Cipher
cCipher CipherChoice
choice
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
hashSize :: Int
hashSize = Hash -> Int
hashDigestSize Hash
usedHash
switchToHandshakeSecret :: IO (Cipher, SecretTriple HandshakeSecret, Bool)
switchToHandshakeSecret = do
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
ByteString
ecdhe <- IO ByteString
calcSharedKey
(BaseSecret EarlySecret
earlySecret, Bool
resuming) <- IO (BaseSecret EarlySecret, Bool)
makeEarlySecret
SecretTriple HandshakeSecret
handKey <- Context
-> CipherChoice
-> BaseSecret EarlySecret
-> ByteString
-> IO (SecretTriple HandshakeSecret)
calculateHandshakeSecret Context
ctx CipherChoice
choice BaseSecret EarlySecret
earlySecret ByteString
ecdhe
let serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
serverHandshakeSecret = forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple HandshakeSecret
handKey
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
forall (m :: * -> *) a. Monad m => a -> m a
return (Cipher
usedCipher, SecretTriple HandshakeSecret
handKey, Bool
resuming)
switchToApplicationSecret :: BaseSecret HandshakeSecret
-> ByteString -> IO (SecretTriple ApplicationSecret)
switchToApplicationSecret BaseSecret HandshakeSecret
handshakeSecret ByteString
hChSf = do
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
SecretTriple ApplicationSecret
appKey <- Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> ByteString
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret Context
ctx CipherChoice
choice BaseSecret HandshakeSecret
handshakeSecret ByteString
hChSf
let serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret
serverApplicationSecret0 = forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey
let clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
clientApplicationSecret0 = forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret ApplicationSecret
clientApplicationSecret0
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret ApplicationSecret
serverApplicationSecret0
forall (m :: * -> *) a. Monad m => a -> m a
return SecretTriple ApplicationSecret
appKey
calcSharedKey :: IO ByteString
calcSharedKey = do
KeyShareEntry
serverKeyShare <- do
Maybe KeyShare
mks <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe KeyShare)
getTLS13KeyShare
case Maybe KeyShare
mks of
Just (KeyShareServerHello KeyShareEntry
ks) -> forall (m :: * -> *) a. Monad m => a -> m a
return KeyShareEntry
ks
Just KeyShare
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid key_share value", Bool
True, AlertDescription
IllegalParameter)
Maybe KeyShare
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"key exchange not implemented, expected key_share extension", Bool
True, AlertDescription
HandshakeFailure)
let grp :: Group
grp = KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
serverKeyShare
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyShareEntry -> Bool
checkKeyShareKeyLength KeyShareEntry
serverKeyShare) 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
"broken key_share", Bool
True, AlertDescription
IllegalParameter)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Group
groupSent forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Group
grp) 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 incompatible group for (EC)DHE", Bool
True, AlertDescription
IllegalParameter)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setNegotiatedGroup Group
grp
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM GroupPrivate
getGroupPrivate forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyShareEntry -> GroupPrivate -> IO ByteString
fromServerKeyShare KeyShareEntry
serverKeyShare
makeEarlySecret :: IO (BaseSecret EarlySecret, Bool)
makeEarlySecret = do
Maybe (BaseSecret EarlySecret)
mEarlySecretPSK <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe (BaseSecret EarlySecret))
getTLS13EarlySecret
case Maybe (BaseSecret EarlySecret)
mEarlySecretPSK of
Maybe (BaseSecret EarlySecret)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice forall a. Maybe a
Nothing, Bool
False)
Just earlySecretPSK :: BaseSecret EarlySecret
earlySecretPSK@(BaseSecret ByteString
sec) -> do
Maybe PreSharedKey
mSelectedIdentity <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe PreSharedKey)
getTLS13PreSharedKey
case Maybe PreSharedKey
mSelectedIdentity of
Maybe PreSharedKey
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return (CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice forall a. Maybe a
Nothing, Bool
False)
Just (PreSharedKeyServerHello Int
0) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
B.length ByteString
sec forall a. Eq a => a -> a -> Bool
== Int
hashSize) 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
"selected cipher is incompatible with selected PSK", Bool
True, AlertDescription
IllegalParameter)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
PreSharedKey
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseSecret EarlySecret
earlySecretPSK, Bool
True)
Just PreSharedKey
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"selected identity out of range", Bool
True, AlertDescription
IllegalParameter)
expectEncryptedExtensions :: Handshake13 -> m (Bool, [ExtensionRaw])
expectEncryptedExtensions (EncryptedExtensions13 [ExtensionRaw]
eexts) = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
MsgTEncryptedExtensions [ExtensionRaw]
eexts
RTT0Status
st <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM RTT0Status
getTLS13RTT0Status
if RTT0Status
st forall a. Eq a => a -> a -> Bool
== RTT0Status
RTT0Sent then
case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_EarlyData [ExtensionRaw]
eexts of
Just ByteString
_ -> do
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
RTT0
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Accepted
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[ExtensionRaw]
eexts)
Maybe ByteString
Nothing -> do
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
RTT0
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Rejected
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[ExtensionRaw]
eexts)
else
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[ExtensionRaw]
eexts)
expectEncryptedExtensions Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"encrypted extensions")
expectCertRequest :: Handshake13 -> RecvHandshake13M m ()
expectCertRequest (CertRequest13 ByteString
token [ExtensionRaw]
exts) = do
forall (m :: * -> *).
MonadIO m =>
Context -> ByteString -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx ByteString
token [ExtensionRaw]
exts
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> RecvHandshake13M m ()
expectCertAndVerify
expectCertRequest Handshake13
other = do
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ do
Maybe ByteString -> HandshakeM ()
setCertReqToken forall a. Maybe a
Nothing
Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata forall a. Maybe a
Nothing
forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> RecvHandshake13M m ()
expectCertAndVerify Handshake13
other
expectCertAndVerify :: Handshake13 -> RecvHandshake13M m ()
expectCertAndVerify (Certificate13 ByteString
_ CertificateChain
cc [[ExtensionRaw]]
_) = do
RecvState IO
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate ClientParams
cparams Context
ctx (CertificateChain -> Handshake
Certificates CertificateChain
cc)
let pubkey :: PubKey
pubkey = Certificate -> PubKey
certPubKey forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate forall a b. (a -> b) -> a -> b
$ CertificateChain -> SignedExact Certificate
getCertificateChainLeaf CertificateChain
cc
Version
ver <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
checkDigitalSignatureKey Version
ver PubKey
pubkey
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ PubKey -> HandshakeM ()
setPublicKey PubKey
pubkey
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
MonadIO m =>
PubKey -> ByteString -> Handshake13 -> m ()
expectCertVerify PubKey
pubkey
expectCertAndVerify Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"server certificate")
expectCertVerify :: PubKey -> ByteString -> Handshake13 -> m ()
expectCertVerify PubKey
pubkey ByteString
hChSc (CertVerify13 HashAndSignatureAlgorithm
sigAlg ByteString
sig) = do
Bool
ok <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> ByteString
-> m Bool
checkCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
sigAlg ByteString
sig ByteString
hChSc
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"cannot verify CertificateVerify"
expectCertVerify PubKey
_ ByteString
_ Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"certificate verify")
expectFinished :: ServerTrafficSecret a -> ByteString -> Handshake13 -> m ()
expectFinished (ServerTrafficSecret ByteString
baseKey) ByteString
hashValue (Finished13 ByteString
verifyData) =
forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
checkFinished Context
ctx Hash
usedHash ByteString
baseKey ByteString
hashValue ByteString
verifyData
expectFinished ServerTrafficSecret a
_ ByteString
_ Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"server finished")
setResumptionSecret :: BaseSecret ApplicationSecret -> IO ()
setResumptionSecret BaseSecret ApplicationSecret
applicationSecret = do
BaseSecret ResumptionSecret
resumptionSecret <- Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret Context
ctx CipherChoice
choice BaseSecret ApplicationSecret
applicationSecret
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ BaseSecret ResumptionSecret -> HandshakeM ()
setTLS13ResumptionSecret BaseSecret ResumptionSecret
resumptionSecret
processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()
processCertRequest13 :: forall (m :: * -> *).
MonadIO m =>
Context -> ByteString -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx ByteString
token [ExtensionRaw]
exts = do
let hsextID :: ExtensionID
hsextID = ExtensionID
extensionID_SignatureAlgorithms
[DistinguishedName]
dNames <- m [DistinguishedName]
canames
Maybe [HashAndSignatureAlgorithm]
hsAlgs <- forall {m :: * -> *} {t} {a}.
(Extension t, MonadIO m) =>
ExtensionID -> (t -> Maybe a) -> m (Maybe a)
extalgs ExtensionID
hsextID SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm]
unsighash
[CertificateType]
cTypes <- case Maybe [HashAndSignatureAlgorithm]
hsAlgs of
Just [HashAndSignatureAlgorithm]
as ->
let validAs :: [HashAndSignatureAlgorithm]
validAs = forall a. (a -> Bool) -> [a] -> [a]
filter HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 [HashAndSignatureAlgorithm]
as
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Context -> [HashAndSignatureAlgorithm] -> [CertificateType]
sigAlgsToCertTypes Context
ctx [HashAndSignatureAlgorithm]
validAs
Maybe [HashAndSignatureAlgorithm]
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
( String
"invalid certificate request"
, Bool
True
, AlertDescription
HandshakeFailure )
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ do
Maybe ByteString -> HandshakeM ()
setCertReqToken forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
token
Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
hsAlgs, [DistinguishedName]
dNames)
where
canames :: m [DistinguishedName]
canames = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup
ExtensionID
extensionID_CertificateAuthorities [ExtensionRaw]
exts of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just ByteString
ext -> case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTCertificateRequest ByteString
ext of
Just (CertificateAuthorities [DistinguishedName]
names) -> forall (m :: * -> *) a. Monad m => a -> m a
return [DistinguishedName]
names
Maybe CertificateAuthorities
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
( String
"invalid certificate request"
, Bool
True
, AlertDescription
HandshakeFailure )
extalgs :: ExtensionID -> (t -> Maybe a) -> m (Maybe a)
extalgs ExtensionID
extID t -> Maybe a
decons = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extID [ExtensionRaw]
exts of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just ByteString
ext -> case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTCertificateRequest ByteString
ext of
Just t
e
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t -> Maybe a
decons t
e
Maybe t
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
( String
"invalid certificate request"
, Bool
True
, AlertDescription
HandshakeFailure )
unsighash :: SignatureAlgorithms
-> Maybe [HashAndSignatureAlgorithm]
unsighash :: SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm]
unsighash (SignatureAlgorithms [HashAndSignatureAlgorithm]
a) = forall a. a -> Maybe a
Just [HashAndSignatureAlgorithm]
a
sendClientFlight13 :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 :: forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash (ClientTrafficSecret ByteString
baseKey) = do
Maybe CertificateChain
chain <- ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ do
case Maybe CertificateChain
chain of
Maybe CertificateChain
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CertificateChain
cc -> forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe ByteString)
getCertReqToken forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {b}.
Monoid b =>
CertificateChain -> Maybe ByteString -> PacketFlightM b ()
sendClientData13 CertificateChain
cc
Handshake13
rawFinished <- forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> m Handshake13
makeFinished Context
ctx Hash
usedHash ByteString
baseKey
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
rawFinished]
where
sendClientData13 :: CertificateChain -> Maybe ByteString -> PacketFlightM b ()
sendClientData13 CertificateChain
chain (Just ByteString
token) = do
let (CertificateChain [SignedExact Certificate]
certs) = CertificateChain
chain
certExts :: [[a]]
certExts = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SignedExact Certificate]
certs) []
cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = forall a. (a -> Bool) -> [a] -> [a]
filter HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [ByteString -> CertificateChain -> [[ExtensionRaw]] -> Handshake13
Certificate13 ByteString
token CertificateChain
chain forall {a}. [[a]]
certExts]
case [SignedExact Certificate]
certs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[SignedExact Certificate]
_ -> do
ByteString
hChSc <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
PubKey
pubKey <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
HashAndSignatureAlgorithm
sigAlg <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
signatureCompatible13 [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey
Handshake13
vfy <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubKey HashAndSignatureAlgorithm
sigAlg ByteString
hChSc
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
vfy]
sendClientData13 CertificateChain
_ Maybe ByteString
_ =
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
( String
"missing TLS 1.3 certificate request context token"
, Bool
True
, AlertDescription
InternalError
)
setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
msgt [ExtensionRaw]
exts = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_ApplicationLayerProtocolNegotiation [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
msgt of
Just (ApplicationLayerProtocolNegotiation [ByteString
proto]) -> forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
Maybe [ByteString]
mprotos <- TLSSt (Maybe [ByteString])
getClientALPNSuggest
case Maybe [ByteString]
mprotos of
Just [ByteString]
protos -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
proto forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
protos) forall a b. (a -> b) -> a -> b
$ do
Bool -> TLSSt ()
setExtensionALPN Bool
True
ByteString -> TLSSt ()
setNegotiatedProtocol ByteString
proto
Maybe [ByteString]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe ApplicationLayerProtocolNegotiation
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthClientWith ClientParams
cparams Context
ctx h :: Handshake13
h@(CertRequest13 ByteString
certReqCtx [ExtensionRaw]
exts) =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx) (Context
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
restoreHState Context
ctx) forall a b. (a -> b) -> a -> b
$ \Saved (Maybe HandshakeState)
_ -> do
Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
forall (m :: * -> *).
MonadIO m =>
Context -> ByteString -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx ByteString
certReqCtx [ExtensionRaw]
exts
(Hash
usedHash, Cipher
_, CryptLevel
level, ByteString
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getTxState Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptLevel
level forall a. Eq a => a -> a -> Bool
== CryptLevel
CryptApplicationSecret) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unexpected post-handshake authentication request", Bool
True, AlertDescription
UnexpectedMessage)
forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash (forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
applicationSecretN)
postHandshakeAuthClientWith ClientParams
_ Context
_ Handshake13
_ =
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unexpected handshake message received in postHandshakeAuthClientWith", Bool
True, AlertDescription
UnexpectedMessage)
contextSync :: Context -> ClientState -> IO ()
contextSync :: Context -> ClientState -> IO ()
contextSync Context
ctx ClientState
ctl = case Context -> HandshakeSync
ctxHandshakeSync Context
ctx of
HandshakeSync Context -> ClientState -> IO ()
sync Context -> ServerState -> IO ()
_ -> Context -> ClientState -> IO ()
sync Context
ctx ClientState
ctl