{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Server
( handshakeServer
, handshakeServerWith
, requestCertificateServer
, postHandshakeAuthServerWith
) where
import Network.TLS.Parameters
import Network.TLS.Imports
import Network.TLS.Context.Internal
import Network.TLS.Session
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Credentials
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Util (bytesEq, catchException, fromJust)
import Network.TLS.IO
import Network.TLS.Types
import Network.TLS.State
import Network.TLS.Handshake.Control
import Network.TLS.Handshake.State
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Random
import Network.TLS.Measurement
import qualified Data.ByteString as B
import Data.X509 (ExtKeyUsageFlag(..))
import Control.Monad.State.Strict
import Control.Exception (bracket)
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Certificate
import Network.TLS.X509
import Network.TLS.Handshake.State13
import Network.TLS.Handshake.Common13
handshakeServer :: ServerParams -> Context -> IO ()
handshakeServer :: ServerParams -> Context -> IO ()
handshakeServer ServerParams
sparams Context
ctx = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
[Handshake]
hss <- Context -> IO [Handshake]
recvPacketHandshake Context
ctx
case [Handshake]
hss of
[Handshake
ch] -> ServerParams -> Context -> Handshake -> IO ()
handshakeServerWith ServerParams
sparams Context
ctx Handshake
ch
[Handshake]
_ -> forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show [Handshake]
hss) (forall a. a -> Maybe a
Just String
"client hello")
handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
handshakeServerWith ServerParams
sparams Context
ctx clientHello :: Handshake
clientHello@(ClientHello Version
legacyVersion ClientRandom
_ Session
clientSession [ExtensionID]
ciphers [CompressionID]
compressions [ExtensionRaw]
exts Maybe ByteString
_) = do
Established
established <- Context -> IO Established
ctxEstablished Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established forall a. Eq a => a -> a -> Bool
/= Established
NotEstablished) forall a b. (a -> b) -> a -> b
$ do
Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Version -> TLSSt Version
getVersionWithDefault Version
TLS10)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver forall a. Eq a => a -> a -> Bool
== Version
TLS13) 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 is not allowed in TLS 1.3", Bool
True, AlertDescription
UnexpectedMessage)
Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
let renegotiation :: Bool
renegotiation = Established
established forall a. Eq a => a -> a -> Bool
== Established
Established Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
renegotiation Bool -> Bool -> Bool
&& Bool -> Bool
not (Supported -> Bool
supportedClientInitiatedRenegotiation forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)) 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 is not allowed", Bool
False, AlertDescription
NoRenegotiation)
Bool
handshakeAuthorized <- forall a. Context -> (Measurement -> IO a) -> IO a
withMeasure Context
ctx (ServerHooks -> Measurement -> IO Bool
onNewHandshake forall a b. (a -> b) -> a -> b
$ ServerParams -> ServerHooks
serverHooks ServerParams
sparams)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handshakeAuthorized (forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_HandshakePolicy String
"server: handshake denied")
Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
ctx Measurement -> Measurement
incrementNbHandshakes
Context -> Handshake -> IO ()
processHandshake Context
ctx Handshake
clientHello
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
legacyVersion 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
"SSL 2.0 is not supported", Bool
True, AlertDescription
ProtocolVersion)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
legacyVersion 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
"SSL 3.0 is not supported", Bool
True, AlertDescription
ProtocolVersion)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Supported -> Bool
supportedFallbackScsv (Context -> Supported
ctxSupported Context
ctx) Bool -> Bool -> Bool
&&
(ExtensionID
0x5600 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtensionID]
ciphers) Bool -> Bool -> Bool
&&
Version
legacyVersion forall a. Ord a => a -> a -> Bool
< Version
TLS12) 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
"fallback is not allowed", Bool
True, AlertDescription
InappropriateFallback)
let clientVersions :: [Version]
clientVersions = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_SupportedVersions [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
MsgTClientHello of
Just (SupportedVersionsClientHello [Version]
vers) -> [Version]
vers
Maybe SupportedVersions
_ -> []
clientVersion :: Version
clientVersion = forall a. Ord a => a -> a -> a
min Version
TLS12 Version
legacyVersion
serverVersions :: [Version]
serverVersions
| Bool
renegotiation = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
< Version
TLS13) (Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)
| Bool
otherwise = Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
mVersion :: Maybe Version
mVersion = DebugParams -> Maybe Version
debugVersionForced forall a b. (a -> b) -> a -> b
$ ServerParams -> DebugParams
serverDebug ServerParams
sparams
Version
chosenVersion <- case Maybe Version
mVersion of
Just Version
cver -> forall (m :: * -> *) a. Monad m => a -> m a
return Version
cver
Maybe Version
Nothing ->
if (Version
TLS13 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Version]
serverVersions) Bool -> Bool -> Bool
&& [Version]
clientVersions forall a. Eq a => a -> a -> Bool
/= [] then case [Version] -> [Version] -> Maybe Version
findHighestVersionFrom13 [Version]
clientVersions [Version]
serverVersions 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
"client versions " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Version]
clientVersions forall a. [a] -> [a] -> [a]
++ String
" is not supported", Bool
True, AlertDescription
ProtocolVersion)
Just Version
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Version
v
else case Version -> [Version] -> Maybe Version
findHighestVersionFrom Version
clientVersion [Version]
serverVersions 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
"client version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
clientVersion forall a. [a] -> [a] -> [a]
++ String
" is not supported", Bool
True, AlertDescription
ProtocolVersion)
Just Version
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Version
v
let serverName :: Maybe String
serverName = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_ServerName [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
MsgTClientHello of
Just (ServerName [ServerNameType]
ns) -> forall a. [a] -> Maybe a
listToMaybe (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ServerNameType -> Maybe String
toHostName [ServerNameType]
ns)
where toHostName :: ServerNameType -> Maybe String
toHostName (ServerNameHostName String
hostName) = forall a. a -> Maybe a
Just String
hostName
toHostName (ServerNameOther (CompressionID, ByteString)
_) = forall a. Maybe a
Nothing
Maybe ServerName
_ -> forall a. Maybe a
Nothing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TLSSt ()
setClientSNI) Maybe String
serverName
if Version
chosenVersion forall a. Ord a => a -> a -> Bool
<= Version
TLS12 then
ServerParams
-> Context
-> Version
-> [ExtensionRaw]
-> [ExtensionID]
-> Maybe String
-> Version
-> [CompressionID]
-> Session
-> IO ()
handshakeServerWithTLS12 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [ExtensionID]
ciphers Maybe String
serverName Version
clientVersion [CompressionID]
compressions Session
clientSession
else do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression [CompressionID]
compressions
ServerParams
-> Context
-> Version
-> [ExtensionRaw]
-> [ExtensionID]
-> Maybe String
-> Session
-> IO ()
handshakeServerWithTLS13 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [ExtensionID]
ciphers Maybe String
serverName Session
clientSession
handshakeServerWith ServerParams
_ 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 handshakeServerWith", Bool
True, AlertDescription
HandshakeFailure)
handshakeServerWithTLS12 :: ServerParams
-> Context
-> Version
-> [ExtensionRaw]
-> [CipherID]
-> Maybe String
-> Version
-> [CompressionID]
-> Session
-> IO ()
handshakeServerWithTLS12 :: ServerParams
-> Context
-> Version
-> [ExtensionRaw]
-> [ExtensionID]
-> Maybe String
-> Version
-> [CompressionID]
-> Session
-> IO ()
handshakeServerWithTLS12 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [ExtensionID]
ciphers Maybe String
serverName Version
clientVersion [CompressionID]
compressions Session
clientSession = do
Credentials
extraCreds <- ServerHooks -> Maybe String -> IO Credentials
onServerNameIndication (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) Maybe String
serverName
let allCreds :: Credentials
allCreds = (Credential -> Bool) -> Credentials -> Credentials
filterCredentials (Version -> [ExtensionRaw] -> Credential -> Bool
isCredentialAllowed Version
chosenVersion [ExtensionRaw]
exts) forall a b. (a -> b) -> a -> b
$
Credentials
extraCreds forall a. Monoid a => a -> a -> a
`mappend` Shared -> Credentials
sharedCredentials (Context -> Shared
ctxShared Context
ctx)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Compression]
commonCompressions) 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
"no compression in common with the client", Bool
True, AlertDescription
HandshakeFailure)
let possibleGroups :: [Group]
possibleGroups = Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
exts
possibleECGroups :: [Group]
possibleECGroups = [Group]
possibleGroups forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableECGroups
possibleFFGroups :: [Group]
possibleFFGroups = [Group]
possibleGroups forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableFFGroups
hasCommonGroupForECDHE :: Bool
hasCommonGroupForECDHE = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
possibleECGroups)
hasCommonGroupForFFDHE :: Bool
hasCommonGroupForFFDHE = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
possibleFFGroups)
hasCustomGroupForFFDHE :: Bool
hasCustomGroupForFFDHE = forall a. Maybe a -> Bool
isJust (ServerParams -> Maybe DHParams
serverDHEParams ServerParams
sparams)
canFFDHE :: Bool
canFFDHE = Bool
hasCustomGroupForFFDHE Bool -> Bool -> Bool
|| Bool
hasCommonGroupForFFDHE
hasCommonGroup :: Cipher -> Bool
hasCommonGroup Cipher
cipher =
case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> Bool
canFFDHE
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> Bool
canFFDHE
CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> Bool
canFFDHE
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Bool
hasCommonGroupForECDHE
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Bool
hasCommonGroupForECDHE
CipherKeyExchangeType
_ -> Bool
True
cipherAllowed :: Cipher -> Bool
cipherAllowed Cipher
cipher = Version -> Cipher -> Bool
cipherAllowedForVersion Version
chosenVersion Cipher
cipher Bool -> Bool -> Bool
&& Cipher -> Bool
hasCommonGroup Cipher
cipher
selectCipher :: Credentials -> Credentials -> [Cipher]
selectCipher Credentials
credentials Credentials
signatureCredentials = forall a. (a -> Bool) -> [a] -> [a]
filter Cipher -> Bool
cipherAllowed (Credentials -> Credentials -> [Cipher]
commonCiphers Credentials
credentials Credentials
signatureCredentials)
(Credentials
creds, Credentials
signatureCreds, [Cipher]
ciphersFilteredVersion)
= case Version
chosenVersion of
Version
TLS12 -> let
possibleHashSigAlgs :: [HashAndSignatureAlgorithm]
possibleHashSigAlgs = Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
exts
signingRank :: Credential -> Maybe Int
signingRank Credential
cred =
case Credential -> Maybe PubKey
credentialDigitalSignatureKey Credential
cred of
Just PubKey
pub -> forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (PubKey
pub PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible`) [HashAndSignatureAlgorithm]
possibleHashSigAlgs
Maybe PubKey
Nothing -> forall a. Maybe a
Nothing
cltCreds :: Credentials
cltCreds = [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures [ExtensionRaw]
exts Credentials
allCreds
sigCltCreds :: Credentials
sigCltCreds = forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe Int
signingRank Credentials
cltCreds
sigAllCreds :: Credentials
sigAllCreds = forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe Int
signingRank Credentials
allCreds
cltCiphers :: [Cipher]
cltCiphers = Credentials -> Credentials -> [Cipher]
selectCipher Credentials
cltCreds Credentials
sigCltCreds
allCiphers :: [Cipher]
allCiphers = Credentials -> Credentials -> [Cipher]
selectCipher Credentials
allCreds Credentials
sigAllCreds
resultTuple :: (Credentials, Credentials, [Cipher])
resultTuple = if [Cipher] -> Bool
cipherListCredentialFallback [Cipher]
cltCiphers
then (Credentials
allCreds, Credentials
sigAllCreds, [Cipher]
allCiphers)
else (Credentials
cltCreds, Credentials
sigCltCreds, [Cipher]
cltCiphers)
in (Credentials, Credentials, [Cipher])
resultTuple
Version
_ ->
let sigAllCreds :: Credentials
sigAllCreds = (Credential -> Bool) -> Credentials -> Credentials
filterCredentials (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential -> Maybe PubKey
credentialDigitalSignatureKey) Credentials
allCreds
allCiphers :: [Cipher]
allCiphers = Credentials -> Credentials -> [Cipher]
selectCipher Credentials
allCreds Credentials
sigAllCreds
in (Credentials
allCreds, Credentials
sigAllCreds, [Cipher]
allCiphers)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cipher]
ciphersFilteredVersion) 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
"no cipher in common with the client", Bool
True, AlertDescription
HandshakeFailure)
let usedCipher :: Cipher
usedCipher = ServerHooks -> Version -> [Cipher] -> Cipher
onCipherChoosing (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) Version
chosenVersion [Cipher]
ciphersFilteredVersion
Maybe Credential
cred <- case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
usedCipher of
CipherKeyExchangeType
CipherKeyExchange_RSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Credentials -> Maybe Credential
credentialsFindForDecrypting Credentials
creds
CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_RSA Credentials
signatureCreds
CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_DSS Credentials
signatureCreds
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_RSA Credentials
signatureCreds
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_ECDSA Credentials
signatureCreds
CipherKeyExchangeType
_ -> 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 algorithm not implemented", Bool
True, AlertDescription
HandshakeFailure)
Bool
ems <- forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMasterSec Context
ctx Version
chosenVersion MessageType
MsgTClientHello [ExtensionRaw]
exts
Maybe SessionData
resumeSessionData <- case Session
clientSession of
(Session (Just ByteString
clientSessionId)) -> do
let resume :: IO (Maybe SessionData)
resume = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResume (Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
clientSessionId
IO (Maybe SessionData)
resume forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
MonadIO m =>
Maybe String -> Bool -> Maybe SessionData -> m (Maybe SessionData)
validateSession Maybe String
serverName Bool
ems
(Session Maybe ByteString
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_EcPointFormats [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
MsgTClientHello of
Just (EcPointFormatsSupported [EcPointFormat]
fs) -> forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ [EcPointFormat] -> TLSSt ()
setClientEcPointFormatSuggest [EcPointFormat]
fs
Maybe EcPointFormatsSupported
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ServerParams
-> Maybe Credential
-> Context
-> Version
-> Cipher
-> Compression
-> Session
-> Maybe SessionData
-> [ExtensionRaw]
-> IO ()
doHandshake ServerParams
sparams Maybe Credential
cred Context
ctx Version
chosenVersion Cipher
usedCipher Compression
usedCompression Session
clientSession Maybe SessionData
resumeSessionData [ExtensionRaw]
exts
where
commonCiphers :: Credentials -> Credentials -> [Cipher]
commonCiphers Credentials
creds Credentials
sigCreds = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtensionID]
ciphers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> ExtensionID
cipherID) (ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers ServerParams
sparams Credentials
creds Credentials
sigCreds)
commonCompressions :: [Compression]
commonCompressions = [Compression] -> [CompressionID] -> [Compression]
compressionIntersectID (Supported -> [Compression]
supportedCompressions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) [CompressionID]
compressions
usedCompression :: Compression
usedCompression = forall a. [a] -> a
head [Compression]
commonCompressions
validateSession :: Maybe String -> Bool -> Maybe SessionData -> m (Maybe SessionData)
validateSession Maybe String
_ Bool
_ Maybe SessionData
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
validateSession Maybe String
sni Bool
ems m :: Maybe SessionData
m@(Just SessionData
sd)
| Version
clientVersion forall a. Ord a => a -> a -> Bool
< SessionData -> Version
sessionVersion SessionData
sd = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| SessionData -> ExtensionID
sessionCipher SessionData
sd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ExtensionID]
ciphers = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| SessionData -> CompressionID
sessionCompression SessionData
sd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CompressionID]
compressions = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| forall a. Maybe a -> Bool
isJust Maybe String
sni Bool -> Bool -> Bool
&& SessionData -> Maybe String
sessionClientSNI SessionData
sd forall a. Eq a => a -> a -> Bool
/= Maybe String
sni = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
ems Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
emsSession = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool -> Bool
not Bool
ems Bool -> Bool -> Bool
&& Bool
emsSession =
let err :: String
err = String
"client resumes an EMS session without EMS"
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)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
m
where emsSession :: Bool
emsSession = SessionFlag
SessionEMS forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SessionData -> [SessionFlag]
sessionFlags SessionData
sd
doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher
-> Compression -> Session -> Maybe SessionData
-> [ExtensionRaw] -> IO ()
doHandshake :: ServerParams
-> Maybe Credential
-> Context
-> Version
-> Cipher
-> Compression
-> Session
-> Maybe SessionData
-> [ExtensionRaw]
-> IO ()
doHandshake ServerParams
sparams Maybe Credential
mcred Context
ctx Version
chosenVersion Cipher
usedCipher Compression
usedCompression Session
clientSession Maybe SessionData
resumeSessionData [ExtensionRaw]
exts = do
case Maybe SessionData
resumeSessionData of
Maybe SessionData
Nothing -> do
IO ()
handshakeSendServerData
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Context -> IO ()
contextFlush Context
ctx
ServerParams -> Context -> IO ()
recvClientData ServerParams
sparams Context
ctx
Context -> Role -> IO ()
sendChangeCipherAndFinish Context
ctx Role
ServerRole
Just SessionData
sessionData -> do
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Session -> Bool -> TLSSt ()
setSession Session
clientSession Bool
True)
Handshake
serverhello <- Session -> IO Handshake
makeServerHello Session
clientSession
Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [Handshake
serverhello]
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
chosenVersion Role
ServerRole ByteString
masterSecret
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MasterSecret
MasterSecret ByteString
masterSecret)
Context -> Role -> IO ()
sendChangeCipherAndFinish Context
ctx Role
ServerRole
Context -> IO ()
recvChangeCipherAndFinish Context
ctx
Context -> IO ()
handshakeTerminate Context
ctx
where
makeServerHello :: Session -> IO Handshake
makeServerHello Session
session = do
ServerRandom
srand <- Context -> Version -> [Version] -> IO ServerRandom
serverRandom Context
ctx Version
chosenVersion forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
case Maybe Credential
mcred of
Just Credential
cred -> forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
storePrivInfoServer Context
ctx Credential
cred
Maybe Credential
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
secReneg <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getSecureRenegotiation
[ExtensionRaw]
secRengExt <- if Bool
secReneg
then do
ByteString
vf <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
ByteString
cvf <- Role -> TLSSt ByteString
getVerifiedData Role
ClientRole
ByteString
svf <- Role -> TLSSt ByteString
getVerifiedData Role
ServerRole
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Extension a => a -> ByteString
extensionEncode (ByteString -> Maybe ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
cvf forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
svf)
forall (m :: * -> *) a. Monad m => a -> m a
return [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_SecureRenegotiation ByteString
vf ]
else forall (m :: * -> *) a. Monad m => a -> m a
return []
Bool
ems <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getExtendedMasterSec
let emsExt :: [ExtensionRaw]
emsExt | Bool
ems = let raw :: ByteString
raw = forall a. Extension a => a -> ByteString
extensionEncode ExtendedMasterSecret
ExtendedMasterSecret
in [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ExtendedMasterSecret ByteString
raw ]
| Bool
otherwise = []
[ExtensionRaw]
protoExt <- Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol Context
ctx [ExtensionRaw]
exts ServerParams
sparams
[ExtensionRaw]
sniExt <- do
Bool
resuming <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
isSessionResuming
if Bool
resuming
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
Maybe String
msni <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe String)
getClientSNI
case Maybe String
msni of
Just String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ServerName ByteString
""]
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
let extensions :: [ExtensionRaw]
extensions = Shared -> [ExtensionRaw]
sharedHelloExtensions (ServerParams -> Shared
serverShared ServerParams
sparams)
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
secRengExt forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
emsExt forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
protoExt forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
sniExt
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Version -> TLSSt ()
setVersion Version
chosenVersion)
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
chosenVersion ServerRandom
srand Cipher
usedCipher Compression
usedCompression
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Version
-> ServerRandom
-> Session
-> ExtensionID
-> CompressionID
-> [ExtensionRaw]
-> Handshake
ServerHello Version
chosenVersion ServerRandom
srand Session
session (Cipher -> ExtensionID
cipherID Cipher
usedCipher)
(Compression -> CompressionID
compressionID Compression
usedCompression) [ExtensionRaw]
extensions
handshakeSendServerData :: IO ()
handshakeSendServerData = do
Session
serverSession <- Context -> IO Session
newSession Context
ctx
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Session -> Bool -> TLSSt ()
setSession Session
serverSession Bool
False)
Handshake
serverhello <- Session -> IO Handshake
makeServerHello Session
serverSession
let certMsg :: Handshake
certMsg = case Maybe Credential
mcred of
Just (CertificateChain
srvCerts, PrivKey
_) -> CertificateChain -> Handshake
Certificates CertificateChain
srvCerts
Maybe Credential
_ -> CertificateChain -> Handshake
Certificates forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [ Handshake
serverhello, Handshake
certMsg ]
Maybe ServerKeyXchgAlgorithmData
skx <- case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
usedCipher of
CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ServerKeyXchgAlgorithmData
generateSKX_DH_Anon
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
KX_RSA
CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
KX_DSS
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
KX_RSA
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
KX_ECDSA
CipherKeyExchangeType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Context -> Packet -> IO ()
sendPacket Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Handshake] -> Packet
Handshake forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerKeyXchgAlgorithmData -> Handshake
ServerKeyXchg) Maybe ServerKeyXchgAlgorithmData
skx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerParams -> Bool
serverWantClientCert ServerParams
sparams) forall a b. (a -> b) -> a -> b
$ do
Version
usedVersion <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
let defaultCertTypes :: [CertificateType]
defaultCertTypes = [ CertificateType
CertificateType_RSA_Sign
, CertificateType
CertificateType_DSS_Sign
, CertificateType
CertificateType_ECDSA_Sign
]
([CertificateType]
certTypes, Maybe [HashAndSignatureAlgorithm]
hashSigs)
| Version
usedVersion forall a. Ord a => a -> a -> Bool
< Version
TLS12 = ([CertificateType]
defaultCertTypes, forall a. Maybe a
Nothing)
| Bool
otherwise =
let as :: [HashAndSignatureAlgorithm]
as = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
in (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HashAndSignatureAlgorithm -> Maybe CertificateType
hashSigToCertType [HashAndSignatureAlgorithm]
as, forall a. a -> Maybe a
Just [HashAndSignatureAlgorithm]
as)
creq :: Handshake
creq = [CertificateType]
-> Maybe [HashAndSignatureAlgorithm]
-> [DistinguishedName]
-> Handshake
CertRequest [CertificateType]
certTypes Maybe [HashAndSignatureAlgorithm]
hashSigs
(forall a b. (a -> b) -> [a] -> [b]
map SignedExact Certificate -> DistinguishedName
extractCAname forall a b. (a -> b) -> a -> b
$ ServerParams -> [SignedExact Certificate]
serverCACertificates ServerParams
sparams)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setCertReqSent Bool
True
Context -> Packet -> IO ()
sendPacket Context
ctx ([Handshake] -> Packet
Handshake [Handshake
creq])
Context -> Packet -> IO ()
sendPacket Context
ctx ([Handshake] -> Packet
Handshake [Handshake
ServerHelloDone])
setup_DHE :: IO ServerDHParams
setup_DHE = do
let possibleFFGroups :: [Group]
possibleFFGroups = Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
exts forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableFFGroups
(DHParams
dhparams, DHPrivate
priv, DHPublic
pub) <-
case [Group]
possibleFFGroups of
[] ->
let dhparams :: DHParams
dhparams = forall a. String -> Maybe a -> a
fromJust String
"server DHE Params" forall a b. (a -> b) -> a -> b
$ ServerParams -> Maybe DHParams
serverDHEParams ServerParams
sparams
in case DHParams -> Maybe Group
findFiniteFieldGroup DHParams
dhparams of
Just Group
g -> 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
g
Context -> Group -> IO (DHParams, DHPrivate, DHPublic)
generateFFDHE Context
ctx Group
g
Maybe Group
Nothing -> do
(DHPrivate
priv, DHPublic
pub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
generateDHE Context
ctx DHParams
dhparams
forall (m :: * -> *) a. Monad m => a -> m a
return (DHParams
dhparams, DHPrivate
priv, DHPublic
pub)
Group
g:[Group]
_ -> 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
g
Context -> Group -> IO (DHParams, DHPrivate, DHPublic)
generateFFDHE Context
ctx Group
g
let serverParams :: ServerDHParams
serverParams = DHParams -> DHPublic -> ServerDHParams
serverDHParamsFrom DHParams
dhparams DHPublic
pub
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerDHParams -> HandshakeM ()
setServerDHParams ServerDHParams
serverParams
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ DHPrivate -> HandshakeM ()
setDHPrivate DHPrivate
priv
forall (m :: * -> *) a. Monad m => a -> m a
return ServerDHParams
serverParams
decideHashSig :: PubKey -> IO (Maybe HashAndSignatureAlgorithm)
decideHashSig PubKey
pubKey = do
Version
usedVersion <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
case Version
usedVersion of
Version
TLS12 -> do
let hashSigs :: [HashAndSignatureAlgorithm]
hashSigs = Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
exts
case forall a. (a -> Bool) -> [a] -> [a]
filter (PubKey
pubKey PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible`) [HashAndSignatureAlgorithm]
hashSigs of
[] -> forall a. HasCallStack => String -> a
error (String
"no hash signature for " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
pubKey)
HashAndSignatureAlgorithm
x:[HashAndSignatureAlgorithm]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just HashAndSignatureAlgorithm
x
Version
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
generateSKX_DHE :: KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
kxsAlg = do
ServerDHParams
serverParams <- IO ServerDHParams
setup_DHE
PubKey
pubKey <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
Maybe HashAndSignatureAlgorithm
mhashSig <- PubKey -> IO (Maybe HashAndSignatureAlgorithm)
decideHashSig PubKey
pubKey
DigitallySigned
signed <- Context
-> ServerDHParams
-> PubKey
-> Maybe HashAndSignatureAlgorithm
-> IO DigitallySigned
digitallySignDHParams Context
ctx ServerDHParams
serverParams PubKey
pubKey Maybe HashAndSignatureAlgorithm
mhashSig
case KeyExchangeSignatureAlg
kxsAlg of
KeyExchangeSignatureAlg
KX_RSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_DHE_RSA ServerDHParams
serverParams DigitallySigned
signed
KeyExchangeSignatureAlg
KX_DSS -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_DHE_DSS ServerDHParams
serverParams DigitallySigned
signed
KeyExchangeSignatureAlg
_ -> forall a. HasCallStack => String -> a
error (String
"generate skx_dhe unsupported key exchange signature: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show KeyExchangeSignatureAlg
kxsAlg)
generateSKX_DH_Anon :: IO ServerKeyXchgAlgorithmData
generateSKX_DH_Anon = ServerDHParams -> ServerKeyXchgAlgorithmData
SKX_DH_Anon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ServerDHParams
setup_DHE
setup_ECDHE :: Group -> IO ServerECDHParams
setup_ECDHE 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
(GroupPrivate
srvpri, GroupPublic
srvpub) <- Context -> Group -> IO (GroupPrivate, GroupPublic)
generateECDHE Context
ctx Group
grp
let serverParams :: ServerECDHParams
serverParams = Group -> GroupPublic -> ServerECDHParams
ServerECDHParams Group
grp GroupPublic
srvpub
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> HandshakeM ()
setServerECDHParams ServerECDHParams
serverParams
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ GroupPrivate -> HandshakeM ()
setGroupPrivate GroupPrivate
srvpri
forall (m :: * -> *) a. Monad m => a -> m a
return ServerECDHParams
serverParams
generateSKX_ECDHE :: KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
kxsAlg = do
let possibleECGroups :: [Group]
possibleECGroups = Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
exts forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableECGroups
Group
grp <- case [Group]
possibleECGroups of
[] -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"no common group", Bool
True, AlertDescription
HandshakeFailure)
Group
g:[Group]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Group
g
ServerECDHParams
serverParams <- Group -> IO ServerECDHParams
setup_ECDHE Group
grp
PubKey
pubKey <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
Maybe HashAndSignatureAlgorithm
mhashSig <- PubKey -> IO (Maybe HashAndSignatureAlgorithm)
decideHashSig PubKey
pubKey
DigitallySigned
signed <- Context
-> ServerECDHParams
-> PubKey
-> Maybe HashAndSignatureAlgorithm
-> IO DigitallySigned
digitallySignECDHParams Context
ctx ServerECDHParams
serverParams PubKey
pubKey Maybe HashAndSignatureAlgorithm
mhashSig
case KeyExchangeSignatureAlg
kxsAlg of
KeyExchangeSignatureAlg
KX_RSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_ECDHE_RSA ServerECDHParams
serverParams DigitallySigned
signed
KeyExchangeSignatureAlg
KX_ECDSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_ECDHE_ECDSA ServerECDHParams
serverParams DigitallySigned
signed
KeyExchangeSignatureAlg
_ -> forall a. HasCallStack => String -> a
error (String
"generate skx_ecdhe unsupported key exchange signature: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show KeyExchangeSignatureAlg
kxsAlg)
recvClientData :: ServerParams -> Context -> IO ()
recvClientData :: ServerParams -> Context -> IO ()
recvClientData ServerParams
sparams Context
ctx = Context -> RecvState IO -> IO ()
runRecvState Context
ctx (forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake Handshake -> IO (RecvState IO)
processClientCertificate)
where processClientCertificate :: Handshake -> IO (RecvState IO)
processClientCertificate (Certificates CertificateChain
certs) = do
ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
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 :: * -> *}. MonadIO m => Handshake -> m (RecvState IO)
processClientKeyExchange
processClientCertificate Handshake
p = forall {m :: * -> *}. MonadIO m => Handshake -> m (RecvState IO)
processClientKeyExchange Handshake
p
processClientKeyExchange :: Handshake -> m (RecvState IO)
processClientKeyExchange (ClientKeyXchg ClientKeyXchgAlgorithmData
_) = 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 forall {m :: * -> *}. MonadIO m => Packet -> IO (RecvState m)
processCertificateVerify
processClientKeyExchange 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
"client key exchange")
processCertificateVerify :: Packet -> IO (RecvState m)
processCertificateVerify (Handshake [hs :: Handshake
hs@(CertVerify DigitallySigned
dsig)]) = do
Context -> Handshake -> IO ()
processHandshake Context
ctx Handshake
hs
CertificateChain
certs <- forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
"change cipher message expected"
Version
usedVersion <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
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
PubKey
pubKey <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM PubKey
getRemotePublicKey
forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
checkDigitalSignatureKey Version
usedVersion PubKey
pubKey
Bool
verif <- Context
-> Version -> PubKey -> ByteString -> DigitallySigned -> IO Bool
checkCertificateVerify Context
ctx Version
usedVersion PubKey
pubKey ByteString
msgs DigitallySigned
dsig
ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif
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 forall {m :: * -> *} {m :: * -> *}.
(MonadIO m, MonadIO m) =>
Packet -> m (RecvState m)
expectChangeCipher
processCertificateVerify Packet
p = do
Maybe CertificateChain
chain <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertificateChain)
getClientCertChain
case Maybe CertificateChain
chain of
Just CertificateChain
cc | CertificateChain -> Bool
isNullCertificateChain CertificateChain
cc -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| 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
"cert verify message missing", Bool
True, AlertDescription
UnexpectedMessage)
Maybe CertificateChain
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall {m :: * -> *} {m :: * -> *}.
(MonadIO m, MonadIO m) =>
Packet -> m (RecvState m)
expectChangeCipher Packet
p
expectChangeCipher :: Packet -> m (RecvState m)
expectChangeCipher Packet
ChangeCipherSpec = do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake forall {m :: * -> *} {m :: * -> *}.
MonadIO m =>
Handshake -> m (RecvState m)
expectFinish
expectChangeCipher Packet
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Packet
p) (forall a. a -> Maybe a
Just String
"change cipher")
expectFinish :: Handshake -> m (RecvState m)
expectFinish (Finished 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")
checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain
checkValidClientCertChain :: forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
errmsg = do
Maybe CertificateChain
chain <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertificateChain)
getClientCertChain
let throwerror :: TLSError
throwerror = (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
errmsg , Bool
True, AlertDescription
UnexpectedMessage)
case Maybe CertificateChain
chain of
Maybe CertificateChain
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
throwerror
Just CertificateChain
cc | CertificateChain -> Bool
isNullCertificateChain CertificateChain
cc -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
throwerror
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return CertificateChain
cc
hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
exts =
let cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_SignatureAlgorithms [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
MsgTClientHello of
Maybe SignatureAlgorithms
Nothing -> [(HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureECDSA)
,(HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureRSA)
,(HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureDSS)]
Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm]
sas
sHashSigs :: [HashAndSignatureAlgorithm]
sHashSigs = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
in [HashAndSignatureAlgorithm]
sHashSigs forall a. Eq a => [a] -> [a] -> [a]
`intersect` [HashAndSignatureAlgorithm]
cHashSigs
negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
exts = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_NegotiatedGroups [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
MsgTClientHello of
Just (NegotiatedGroups [Group]
clientGroups) ->
let serverGroups :: [Group]
serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
in [Group]
serverGroups forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
clientGroups
Maybe NegotiatedGroups
_ -> []
credentialDigitalSignatureKey :: Credential -> Maybe PubKey
credentialDigitalSignatureKey :: Credential -> Maybe PubKey
credentialDigitalSignatureKey Credential
cred
| (PubKey, PrivKey) -> Bool
isDigitalSignaturePair (PubKey, PrivKey)
keys = forall a. a -> Maybe a
Just PubKey
pubkey
| Bool
otherwise = forall a. Maybe a
Nothing
where keys :: (PubKey, PrivKey)
keys@(PubKey
pubkey, PrivKey
_) = Credential -> (PubKey, PrivKey)
credentialPublicPrivateKeys Credential
cred
filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials
filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials
filterCredentials Credential -> Bool
p (Credentials [Credential]
l) = [Credential] -> Credentials
Credentials (forall a. (a -> Bool) -> [a] -> [a]
filter Credential -> Bool
p [Credential]
l)
filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials :: forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe a
rankFun (Credentials [Credential]
creds) =
let orderedPairs :: [(Maybe a, Credential)]
orderedPairs = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [ (Credential -> Maybe a
rankFun Credential
cred, Credential
cred) | Credential
cred <- [Credential]
creds ]
in [Credential] -> Credentials
Credentials [ Credential
cred | (Just a
_, Credential
cred) <- [(Maybe a, Credential)]
orderedPairs ]
isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool
isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool
isCredentialAllowed Version
ver [ExtensionRaw]
exts Credential
cred =
PubKey
pubkey PubKey -> Version -> Bool
`versionCompatible` Version
ver Bool -> Bool -> Bool
&& (Group -> Bool) -> PubKey -> Bool
satisfiesEcPredicate Group -> Bool
p PubKey
pubkey
where
(PubKey
pubkey, PrivKey
_) = Credential -> (PubKey, PrivKey)
credentialPublicPrivateKeys Credential
cred
p :: Group -> Bool
p | Version
ver forall a. Ord a => a -> a -> Bool
< Version
TLS13 = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_NegotiatedGroups [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
MsgTClientHello of
Maybe NegotiatedGroups
Nothing -> forall a b. a -> b -> a
const Bool
True
Just (NegotiatedGroups [Group]
sg) -> (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
sg)
| Bool
otherwise = forall a b. a -> b -> a
const Bool
True
filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures [ExtensionRaw]
exts =
case forall {b}. Extension b => ExtensionID -> Maybe b
withExt ExtensionID
extensionID_SignatureAlgorithmsCert of
Just (SignatureAlgorithmsCert [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> Credentials -> Credentials
withAlgs [HashAndSignatureAlgorithm]
sas
Maybe SignatureAlgorithmsCert
Nothing ->
case forall {b}. Extension b => ExtensionID -> Maybe b
withExt ExtensionID
extensionID_SignatureAlgorithms of
Maybe SignatureAlgorithms
Nothing -> forall a. a -> a
id
Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> Credentials -> Credentials
withAlgs [HashAndSignatureAlgorithm]
sas
where
withExt :: ExtensionID -> Maybe b
withExt ExtensionID
extId = ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extId [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
MsgTClientHello
withAlgs :: [HashAndSignatureAlgorithm] -> Credentials -> Credentials
withAlgs [HashAndSignatureAlgorithm]
sas = (Credential -> Bool) -> Credentials -> Credentials
filterCredentials ([HashAndSignatureAlgorithm] -> Credential -> Bool
credentialMatchesHashSignatures [HashAndSignatureAlgorithm]
sas)
cipherListCredentialFallback :: [Cipher] -> Bool
cipherListCredentialFallback :: [Cipher] -> Bool
cipherListCredentialFallback = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Cipher -> Bool
nonDH
where
nonDH :: Cipher -> Bool
nonDH Cipher
x = case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
x of
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_TLS13 -> Bool
False
CipherKeyExchangeType
_ -> Bool
True
storePrivInfoServer :: MonadIO m => Context -> Credential -> m ()
storePrivInfoServer :: forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
storePrivInfoServer Context
ctx (CertificateChain
cc, PrivKey
privkey) = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *).
MonadIO m =>
Context -> CertificateChain -> PrivKey -> m PubKey
storePrivInfo Context
ctx CertificateChain
cc PrivKey
privkey)
handshakeServerWithTLS13 :: ServerParams
-> Context
-> Version
-> [ExtensionRaw]
-> [CipherID]
-> Maybe String
-> Session
-> IO ()
handshakeServerWithTLS13 :: ServerParams
-> Context
-> Version
-> [ExtensionRaw]
-> [ExtensionID]
-> Maybe String
-> Session
-> IO ()
handshakeServerWithTLS13 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [ExtensionID]
clientCiphers Maybe String
_serverName Session
clientSession = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(ExtensionRaw ExtensionID
eid ByteString
_) -> ExtensionID
eid forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_PreSharedKey) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
init [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
"extension pre_shared_key must be last", Bool
True, AlertDescription
IllegalParameter)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cipher]
ciphersFilteredVersion) 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
"no cipher in common with the client", Bool
True, AlertDescription
HandshakeFailure)
let usedCipher :: Cipher
usedCipher = ServerHooks -> Version -> [Cipher] -> Cipher
onCipherChoosing (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) Version
chosenVersion [Cipher]
ciphersFilteredVersion
usedHash :: Hash
usedHash = Cipher -> Hash
cipherHash Cipher
usedCipher
rtt0 :: Bool
rtt0 = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_EarlyData [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
MsgTClientHello of
Just (EarlyDataIndication Maybe Word32
_) -> Bool
True
Maybe EarlyDataIndication
Nothing -> Bool
False
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtt0 forall a b. (a -> b) -> a -> b
$
Context -> Established -> IO ()
setEstablished Context
ctx (Int -> Established
EarlyDataNotAllowed Int
3)
[KeyShareEntry]
keyShares <- case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_KeyShare [ExtensionRaw]
exts of
Maybe ByteString
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
MissingExtension)
Just ByteString
kss -> case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello ByteString
kss of
Just (KeyShareClientHello [KeyShareEntry]
kses) -> forall (m :: * -> *) a. Monad m => a -> m a
return [KeyShareEntry]
kses
Just KeyShare
_ -> forall a. HasCallStack => String -> a
error String
"handshakeServerWithTLS13: invalid KeyShare value"
Maybe KeyShare
_ -> 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
DecodeError)
Maybe KeyShareEntry
mshare <- [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)
findKeyShare [KeyShareEntry]
keyShares [Group]
serverGroups
case Maybe KeyShareEntry
mshare of
Maybe KeyShareEntry
Nothing -> ServerParams
-> Context
-> Version
-> Cipher
-> [ExtensionRaw]
-> [Group]
-> Session
-> IO ()
helloRetryRequest ServerParams
sparams Context
ctx Version
chosenVersion Cipher
usedCipher [ExtensionRaw]
exts [Group]
serverGroups Session
clientSession
Just KeyShareEntry
keyShare -> ServerParams
-> Context
-> Version
-> Cipher
-> [ExtensionRaw]
-> Hash
-> KeyShareEntry
-> Session
-> Bool
-> IO ()
doHandshake13 ServerParams
sparams Context
ctx Version
chosenVersion Cipher
usedCipher [ExtensionRaw]
exts Hash
usedHash KeyShareEntry
keyShare Session
clientSession Bool
rtt0
where
ciphersFilteredVersion :: [Cipher]
ciphersFilteredVersion = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtensionID]
clientCiphers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> ExtensionID
cipherID) [Cipher]
serverCiphers
serverCiphers :: [Cipher]
serverCiphers = forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> Cipher -> Bool
cipherAllowedForVersion Version
chosenVersion) (Supported -> [Cipher]
supportedCiphers forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams)
serverGroups :: [Group]
serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)
findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)
findKeyShare [KeyShareEntry]
ks [Group]
ggs = forall {m :: * -> *}.
MonadIO m =>
[Group] -> m (Maybe KeyShareEntry)
go [Group]
ggs
where
go :: [Group] -> m (Maybe KeyShareEntry)
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
go (Group
g:[Group]
gs) = case forall a. (a -> Bool) -> [a] -> [a]
filter (Group -> KeyShareEntry -> Bool
grpEq Group
g) [KeyShareEntry]
ks of
[] -> [Group] -> m (Maybe KeyShareEntry)
go [Group]
gs
[KeyShareEntry
k] -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyShareEntry -> Bool
checkKeyShareKeyLength KeyShareEntry
k) 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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just KeyShareEntry
k
[KeyShareEntry]
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"duplicated key_share", Bool
True, AlertDescription
IllegalParameter)
grpEq :: Group -> KeyShareEntry -> Bool
grpEq Group
g KeyShareEntry
ent = Group
g forall a. Eq a => a -> a -> Bool
== KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
ent
doHandshake13 :: ServerParams -> Context -> Version
-> Cipher -> [ExtensionRaw]
-> Hash -> KeyShareEntry
-> Session -> Bool
-> IO ()
doHandshake13 :: ServerParams
-> Context
-> Version
-> Cipher
-> [ExtensionRaw]
-> Hash
-> KeyShareEntry
-> Session
-> Bool
-> IO ()
doHandshake13 ServerParams
sparams Context
ctx Version
chosenVersion Cipher
usedCipher [ExtensionRaw]
exts Hash
usedHash KeyShareEntry
clientKeyShare Session
clientSession Bool
rtt0 = do
Context -> IO Session
newSession Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Session
ss -> forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
Session -> Bool -> TLSSt ()
setSession Session
ss Bool
False
Bool -> TLSSt ()
setClientSupportsPHA Bool
supportsPHA
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setNegotiatedGroup forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
clientKeyShare
ServerRandom
srand <- IO ServerRandom
setServerParameter
[ExtensionRaw]
protoExt <- Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol Context
ctx [ExtensionRaw]
exts ServerParams
sparams
(ByteString
psk, Maybe (ByteString, Int, Int)
binderInfo, Bool
is0RTTvalid) <- IO (ByteString, Maybe (ByteString, Int, Int), Bool)
choosePSK
SecretPair EarlySecret
earlyKey <- Context
-> CipherChoice
-> Either ByteString (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret Context
ctx CipherChoice
choice (forall a b. a -> Either a b
Left ByteString
psk) Bool
True
let earlySecret :: BaseSecret EarlySecret
earlySecret = forall a. SecretPair a -> BaseSecret a
pairBase SecretPair EarlySecret
earlyKey
clientEarlySecret :: ClientTrafficSecret EarlySecret
clientEarlySecret = forall a. SecretPair a -> ClientTrafficSecret a
pairClient SecretPair EarlySecret
earlyKey
[ExtensionRaw]
extensions <- forall {b}.
Integral b =>
BaseSecret EarlySecret
-> Maybe (ByteString, b, Int) -> IO [ExtensionRaw]
checkBinder BaseSecret EarlySecret
earlySecret Maybe (ByteString, Int, Int)
binderInfo
Bool
hrr <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
let authenticated :: Bool
authenticated = forall a. Maybe a -> Bool
isJust Maybe (ByteString, Int, Int)
binderInfo
rtt0OK :: Bool
rtt0OK = Bool
authenticated Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hrr Bool -> Bool -> Bool
&& Bool
rtt0 Bool -> Bool -> Bool
&& Bool
rtt0accept Bool -> Bool -> Bool
&& Bool
is0RTTvalid
Credentials
extraCreds <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe String)
getClientSNI forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerHooks -> Maybe String -> IO Credentials
onServerNameIndication (ServerParams -> ServerHooks
serverHooks ServerParams
sparams)
let allCreds :: Credentials
allCreds = (Credential -> Bool) -> Credentials -> Credentials
filterCredentials (Version -> [ExtensionRaw] -> Credential -> Bool
isCredentialAllowed Version
chosenVersion [ExtensionRaw]
exts) forall a b. (a -> b) -> a -> b
$
Credentials
extraCreds forall a. Monoid a => a -> a -> a
`mappend` Shared -> Credentials
sharedCredentials (Context -> Shared
ctxShared Context
ctx)
Established
established <- Context -> IO Established
ctxEstablished Context
ctx
if Established
established forall a. Eq a => a -> a -> Bool
/= Established
NotEstablished then
if Bool
rtt0OK then 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
else 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
else
if Bool
authenticated then
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
else
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe (Credential, HashAndSignatureAlgorithm)
mCredInfo <- if Bool
authenticated then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing else forall {m :: * -> *}.
MonadIO m =>
Credentials -> m (Maybe (Credential, HashAndSignatureAlgorithm))
decideCredentialInfo Credentials
allCreds
(ByteString
ecdhe,KeyShareEntry
keyShare) <- Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)
makeServerKeyShare Context
ctx KeyShareEntry
clientKeyShare
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
(ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, BaseSecret HandshakeSecret
handSecret) <- forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ do
forall {b}.
Monoid b =>
KeyShareEntry
-> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
sendServerHello KeyShareEntry
keyShare ServerRandom
srand [ExtensionRaw]
extensions
forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
SecretTriple HandshakeSecret
handKey <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
clientHandshakeSecret = forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple HandshakeSecret
handKey
handSecret :: BaseSecret HandshakeSecret
handSecret = forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple HandshakeSecret
handKey
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
if Bool
rtt0OK Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)
then forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret
else forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
let mEarlySecInfo :: Maybe EarlySecretInfo
mEarlySecInfo
| Bool
rtt0OK = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cipher -> ClientTrafficSecret EarlySecret -> EarlySecretInfo
EarlySecretInfo Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret
| Bool
otherwise = forall a. Maybe a
Nothing
handSecInfo :: HandshakeSecretInfo
handSecInfo = Cipher -> TrafficSecrets HandshakeSecret -> HandshakeSecretInfo
HandshakeSecretInfo Cipher
usedCipher (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret,ServerTrafficSecret HandshakeSecret
serverHandshakeSecret)
Context -> ServerState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ [ExtensionRaw]
-> Maybe EarlySecretInfo -> HandshakeSecretInfo -> ServerState
SendServerHello [ExtensionRaw]
exts Maybe EarlySecretInfo
mEarlySecInfo HandshakeSecretInfo
handSecInfo
forall {b}.
Monoid b =>
Bool -> [ExtensionRaw] -> PacketFlightM b ()
sendExtensions Bool
rtt0OK [ExtensionRaw]
protoExt
case Maybe (Credential, HashAndSignatureAlgorithm)
mCredInfo of
Maybe (Credential, HashAndSignatureAlgorithm)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Credential
cred, HashAndSignatureAlgorithm
hashSig) -> forall {b}.
Monoid b =>
Credential -> HashAndSignatureAlgorithm -> PacketFlightM b ()
sendCertAndVerify Credential
cred HashAndSignatureAlgorithm
hashSig
let ServerTrafficSecret ByteString
shs = ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
Handshake13
rawFinished <- forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> m Handshake13
makeFinished Context
ctx Hash
usedHash ByteString
shs
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
rawFinished]
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, BaseSecret HandshakeSecret
handSecret)
Millisecond
sfSentTime <- IO Millisecond
getCurrentTimeFromBase
ByteString
hChSf <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
SecretTriple ApplicationSecret
appKey <- Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> ByteString
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret Context
ctx CipherChoice
choice BaseSecret HandshakeSecret
handSecret ByteString
hChSf
let clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
clientApplicationSecret0 = forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey
serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret
serverApplicationSecret0 = forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey
applicationSecret :: BaseSecret ApplicationSecret
applicationSecret = forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple ApplicationSecret
appKey
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret ApplicationSecret
serverApplicationSecret0
let appSecInfo :: ApplicationSecretInfo
appSecInfo = TrafficSecrets ApplicationSecret -> ApplicationSecretInfo
ApplicationSecretInfo (ClientTrafficSecret ApplicationSecret
clientApplicationSecret0,ServerTrafficSecret ApplicationSecret
serverApplicationSecret0)
Context -> ServerState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ ApplicationSecretInfo -> ServerState
SendServerFinished ApplicationSecretInfo
appSecInfo
if Bool
rtt0OK then
Context -> Established -> IO ()
setEstablished Context
ctx (Int -> Established
EarlyDataAllowed Int
rtt0max)
else forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established forall a. Eq a => a -> a -> Bool
== Established
NotEstablished) forall a b. (a -> b) -> a -> b
$
Context -> Established -> IO ()
setEstablished Context
ctx (Int -> Established
EarlyDataNotAllowed Int
3)
let expectFinished :: ByteString -> Handshake13 -> m ()
expectFinished ByteString
hChBeforeCf (Finished13 ByteString
verifyData) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let ClientTrafficSecret ByteString
chs = ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
checkFinished Context
ctx Hash
usedHash ByteString
chs ByteString
hChBeforeCf ByteString
verifyData
Context -> IO ()
handshakeTerminate13 Context
ctx
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret ApplicationSecret
clientApplicationSecret0
BaseSecret ApplicationSecret -> Millisecond -> IO ()
sendNewSessionTicket BaseSecret ApplicationSecret
applicationSecret Millisecond
sfSentTime
expectFinished ByteString
_ Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (forall a. a -> Maybe a
Just String
"finished 13")
let expectEndOfEarlyData :: Handshake13 -> IO ()
expectEndOfEarlyData Handshake13
EndOfEarlyData13 =
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
expectEndOfEarlyData Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (forall a. a -> Maybe a
Just String
"end of early data")
if Bool -> Bool
not Bool
authenticated Bool -> Bool -> Bool
&& ServerParams -> Bool
serverWantClientCert ServerParams
sparams then
forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 forall a b. (a -> b) -> a -> b
$ do
Bool
skip <- forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx Handshake13 -> RecvHandshake13M IO Bool
expectCertificate
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
skip forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx (forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx)
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall {m :: * -> *}.
MonadIO m =>
ByteString -> Handshake13 -> m ()
expectFinished
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
else if Bool
rtt0OK Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx) then
Context -> [PendingAction] -> IO ()
setPendingActions Context
ctx [Bool -> (Handshake13 -> IO ()) -> PendingAction
PendingAction Bool
True Handshake13 -> IO ()
expectEndOfEarlyData
,Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
True forall {m :: * -> *}.
MonadIO m =>
ByteString -> Handshake13 -> m ()
expectFinished]
else
forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall {m :: * -> *}.
MonadIO m =>
ByteString -> Handshake13 -> m ()
expectFinished
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
where
choice :: CipherChoice
choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
chosenVersion Cipher
usedCipher
setServerParameter :: IO ServerRandom
setServerParameter = do
ServerRandom
srand <- Context -> Version -> [Version] -> IO ServerRandom
serverRandom Context
ctx Version
chosenVersion forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> TLSSt ()
setVersion Version
chosenVersion
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
usedCipher
forall (m :: * -> *) a. Monad m => a -> m a
return ServerRandom
srand
supportsPHA :: Bool
supportsPHA = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_PostHandshakeAuth [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
MsgTClientHello of
Just PostHandshakeAuth
PostHandshakeAuth -> Bool
True
Maybe PostHandshakeAuth
Nothing -> Bool
False
choosePSK :: IO (ByteString, Maybe (ByteString, Int, Int), Bool)
choosePSK = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_PreSharedKey [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
MsgTClientHello of
Just (PreSharedKeyClientHello (PskIdentity ByteString
sessionId Word32
obfAge:[PskIdentity]
_) bnds :: [ByteString]
bnds@(ByteString
bnd:[ByteString]
_)) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PskKexMode]
dhModes) 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
"no psk_key_exchange_modes extension", Bool
True, AlertDescription
MissingExtension)
if PskKexMode
PSK_DHE_KE forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes then do
let len :: Int
len = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
x -> ByteString -> Int
B.length ByteString
x forall a. Num a => a -> a -> a
+ Int
1) [ByteString]
bnds) forall a. Num a => a -> a -> a
+ Int
2
mgr :: SessionManager
mgr = Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ ServerParams -> Shared
serverShared ServerParams
sparams
Maybe SessionData
msdata <- if Bool
rtt0 then SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResumeOnlyOnce SessionManager
mgr ByteString
sessionId
else SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResume SessionManager
mgr ByteString
sessionId
case Maybe SessionData
msdata of
Just SessionData
sdata -> do
let Just TLS13TicketInfo
tinfo = SessionData -> Maybe TLS13TicketInfo
sessionTicketInfo SessionData
sdata
psk :: ByteString
psk = SessionData -> ByteString
sessionSecret SessionData
sdata
Bool
isFresh <- TLS13TicketInfo -> Word32 -> IO Bool
checkFreshness TLS13TicketInfo
tinfo Word32
obfAge
(Bool
isPSKvalid, Bool
is0RTTvalid) <- SessionData -> IO (Bool, Bool)
checkSessionEquality SessionData
sdata
if Bool
isPSKvalid Bool -> Bool -> Bool
&& Bool
isFresh then
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
psk, forall a. a -> Maybe a
Just (ByteString
bnd,Int
0::Int,Int
len),Bool
is0RTTvalid)
else
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, forall a. Maybe a
Nothing, Bool
False)
Maybe SessionData
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, forall a. Maybe a
Nothing, Bool
False)
else forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, forall a. Maybe a
Nothing, Bool
False)
Maybe PreSharedKey
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, forall a. Maybe a
Nothing, Bool
False)
checkSessionEquality :: SessionData -> IO (Bool, Bool)
checkSessionEquality SessionData
sdata = do
Maybe String
msni <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe String)
getClientSNI
Maybe ByteString
malpn <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe ByteString)
getNegotiatedProtocol
let isSameSNI :: Bool
isSameSNI = SessionData -> Maybe String
sessionClientSNI SessionData
sdata forall a. Eq a => a -> a -> Bool
== Maybe String
msni
isSameCipher :: Bool
isSameCipher = SessionData -> ExtensionID
sessionCipher SessionData
sdata forall a. Eq a => a -> a -> Bool
== Cipher -> ExtensionID
cipherID Cipher
usedCipher
ciphers :: [Cipher]
ciphers = Supported -> [Cipher]
supportedCiphers forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
isSameKDF :: Bool
isSameKDF = case 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 of
Maybe Cipher
Nothing -> Bool
False
Just Cipher
c -> Cipher -> Hash
cipherHash Cipher
c forall a. Eq a => a -> a -> Bool
== Cipher -> Hash
cipherHash Cipher
usedCipher
isSameVersion :: Bool
isSameVersion = Version
chosenVersion forall a. Eq a => a -> a -> Bool
== SessionData -> Version
sessionVersion SessionData
sdata
isSameALPN :: Bool
isSameALPN = SessionData -> Maybe ByteString
sessionALPN SessionData
sdata forall a. Eq a => a -> a -> Bool
== Maybe ByteString
malpn
isPSKvalid :: Bool
isPSKvalid = Bool
isSameKDF Bool -> Bool -> Bool
&& Bool
isSameSNI
is0RTTvalid :: Bool
is0RTTvalid = Bool
isSameVersion Bool -> Bool -> Bool
&& Bool
isSameCipher Bool -> Bool -> Bool
&& Bool
isSameALPN
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isPSKvalid, Bool
is0RTTvalid)
rtt0max :: Int
rtt0max = forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverEarlyDataSize ServerParams
sparams
rtt0accept :: Bool
rtt0accept = ServerParams -> Int
serverEarlyDataSize ServerParams
sparams forall a. Ord a => a -> a -> Bool
> Int
0
checkBinder :: BaseSecret EarlySecret
-> Maybe (ByteString, b, Int) -> IO [ExtensionRaw]
checkBinder BaseSecret EarlySecret
_ Maybe (ByteString, b, Int)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return []
checkBinder BaseSecret EarlySecret
earlySecret (Just (ByteString
binder,b
n,Int
tlen)) = do
ByteString
binder' <- Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe ByteString
-> IO ByteString
makePSKBinder Context
ctx BaseSecret EarlySecret
earlySecret Hash
usedHash Int
tlen forall a. Maybe a
Nothing
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
binder ByteString -> ByteString -> Bool
`bytesEq` ByteString
binder') forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"PSK binder validation failed"
let selectedIdentity :: ByteString
selectedIdentity = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Int -> PreSharedKey
PreSharedKeyServerHello forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral b
n
forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_PreSharedKey ByteString
selectedIdentity]
decideCredentialInfo :: Credentials -> m (Maybe (Credential, HashAndSignatureAlgorithm))
decideCredentialInfo Credentials
allCreds = do
[HashAndSignatureAlgorithm]
cHashSigs <- case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_SignatureAlgorithms [ExtensionRaw]
exts of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"no signature_algorithms extension", Bool
True, AlertDescription
MissingExtension)
Just ByteString
sa -> case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello ByteString
sa of
Maybe SignatureAlgorithms
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"broken signature_algorithms extension", Bool
True, AlertDescription
DecodeError)
Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> forall (m :: * -> *) a. Monad m => a -> m a
return [HashAndSignatureAlgorithm]
sas
let sHashSigs :: [HashAndSignatureAlgorithm]
sHashSigs = 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
hashSigs :: [HashAndSignatureAlgorithm]
hashSigs = [HashAndSignatureAlgorithm]
sHashSigs forall a. Eq a => [a] -> [a] -> [a]
`intersect` [HashAndSignatureAlgorithm]
cHashSigs
cltCreds :: Credentials
cltCreds = [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures [ExtensionRaw]
exts Credentials
allCreds
case [HashAndSignatureAlgorithm]
-> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 [HashAndSignatureAlgorithm]
hashSigs Credentials
cltCreds of
Maybe (Credential, HashAndSignatureAlgorithm)
Nothing ->
case [HashAndSignatureAlgorithm]
-> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 [HashAndSignatureAlgorithm]
hashSigs Credentials
allCreds of
Maybe (Credential, 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
"credential not found", Bool
True, AlertDescription
HandshakeFailure)
Maybe (Credential, HashAndSignatureAlgorithm)
mcs -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs
Maybe (Credential, HashAndSignatureAlgorithm)
mcs -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs
sendServerHello :: KeyShareEntry
-> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
sendServerHello KeyShareEntry
keyShare ServerRandom
srand [ExtensionRaw]
extensions = do
let serverKeyShare :: ByteString
serverKeyShare = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> KeyShare
KeyShareServerHello KeyShareEntry
keyShare
selectedVersion :: ByteString
selectedVersion = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
chosenVersion
extensions' :: [ExtensionRaw]
extensions' = ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_KeyShare ByteString
serverKeyShare
forall a. a -> [a] -> [a]
: ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_SupportedVersions ByteString
selectedVersion
forall a. a -> [a] -> [a]
: [ExtensionRaw]
extensions
helo :: Handshake13
helo = ServerRandom
-> Session -> ExtensionID -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
srand Session
clientSession (Cipher -> ExtensionID
cipherID Cipher
usedCipher) [ExtensionRaw]
extensions'
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
helo]
sendCertAndVerify :: Credential -> HashAndSignatureAlgorithm -> PacketFlightM b ()
sendCertAndVerify cred :: Credential
cred@(CertificateChain
certChain, PrivKey
_) HashAndSignatureAlgorithm
hashSig = do
forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
storePrivInfoServer Context
ctx Credential
cred
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerParams -> Bool
serverWantClientCert ServerParams
sparams) forall a b. (a -> b) -> a -> b
$ do
let certReqCtx :: ByteString
certReqCtx = ByteString
""
certReq :: Handshake13
certReq = ServerParams -> Context -> ByteString -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
certReq]
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setCertReqSent Bool
True
let CertificateChain [SignedExact Certificate]
cs = CertificateChain
certChain
ess :: [[a]]
ess = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SignedExact Certificate]
cs) []
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
"" CertificateChain
certChain forall {a}. [[a]]
ess]
ByteString
hChSc <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
PubKey
pubkey <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
Handshake13
vrfy <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
hashSig ByteString
hChSc
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
vrfy]
sendExtensions :: Bool -> [ExtensionRaw] -> PacketFlightM b ()
sendExtensions Bool
rtt0OK [ExtensionRaw]
protoExt = do
Maybe String
msni <- 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 (Maybe String)
getClientSNI
let sniExtension :: Maybe ExtensionRaw
sniExtension = case Maybe String
msni of
Just String
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ServerName ByteString
""
Maybe String
Nothing -> forall a. Maybe a
Nothing
Maybe Group
mgroup <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe Group)
getNegotiatedGroup
let serverGroups :: [Group]
serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
groupExtension :: Maybe ExtensionRaw
groupExtension
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
serverGroups = forall a. Maybe a
Nothing
| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== forall a. [a] -> a
head [Group]
serverGroups) Maybe Group
mgroup = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_NegotiatedGroups forall a b. (a -> b) -> a -> b
$ forall a. Extension a => a -> ByteString
extensionEncode ([Group] -> NegotiatedGroups
NegotiatedGroups [Group]
serverGroups)
let earlyDataExtension :: Maybe ExtensionRaw
earlyDataExtension
| Bool
rtt0OK = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_EarlyData forall a b. (a -> b) -> a -> b
$ forall a. Extension a => a -> ByteString
extensionEncode (Maybe Word32 -> EarlyDataIndication
EarlyDataIndication forall a. Maybe a
Nothing)
| Bool
otherwise = forall a. Maybe a
Nothing
let extensions :: [ExtensionRaw]
extensions = Shared -> [ExtensionRaw]
sharedHelloExtensions (ServerParams -> Shared
serverShared ServerParams
sparams)
forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [Maybe ExtensionRaw
earlyDataExtension
,Maybe ExtensionRaw
groupExtension
,Maybe ExtensionRaw
sniExtension
]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
protoExt
[ExtensionRaw]
extensions' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ServerHooks -> [ExtensionRaw] -> IO [ExtensionRaw]
onEncryptedExtensionsCreating (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) [ExtensionRaw]
extensions
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [[ExtensionRaw] -> Handshake13
EncryptedExtensions13 [ExtensionRaw]
extensions']
sendNewSessionTicket :: BaseSecret ApplicationSecret -> Millisecond -> IO ()
sendNewSessionTicket BaseSecret ApplicationSecret
applicationSecret Millisecond
sfSentTime = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sendNST forall a b. (a -> b) -> a -> b
$ do
Millisecond
cfRecvTime <- IO Millisecond
getCurrentTimeFromBase
let rtt :: Millisecond
rtt = Millisecond
cfRecvTime forall a. Num a => a -> a -> a
- Millisecond
sfSentTime
ByteString
nonce <- Context -> Int -> IO ByteString
getStateRNG Context
ctx Int
32
BaseSecret ResumptionSecret
resumptionMasterSecret <- Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret Context
ctx CipherChoice
choice BaseSecret ApplicationSecret
applicationSecret
let life :: Word32
life = forall {a} {a}. (Num a, Integral a) => a -> a
toSeconds forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverTicketLifetime ServerParams
sparams
psk :: ByteString
psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionMasterSecret ByteString
nonce
(ByteString
label, Word32
add) <- Word32
-> ByteString -> Int -> Millisecond -> IO (ByteString, Word32)
generateSession Word32
life ByteString
psk Int
rtt0max Millisecond
rtt
let nst :: Handshake13
nst = forall {p}.
Integral p =>
Word32 -> Word32 -> ByteString -> ByteString -> p -> Handshake13
createNewSessionTicket Word32
life Word32
add ByteString
nonce ByteString
label Int
rtt0max
Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
nst]
where
sendNST :: Bool
sendNST = PskKexMode
PSK_DHE_KE forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes
generateSession :: Word32
-> ByteString -> Int -> Millisecond -> IO (ByteString, Word32)
generateSession Word32
life ByteString
psk Int
maxSize Millisecond
rtt = do
Session (Just ByteString
sessionId) <- Context -> IO Session
newSession Context
ctx
TLS13TicketInfo
tinfo <- Word32
-> Either Context Word32 -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Word32
life (forall a b. a -> Either a b
Left Context
ctx) (forall a. a -> Maybe a
Just Millisecond
rtt)
SessionData
sdata <- Context
-> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
getSessionData13 Context
ctx Cipher
usedCipher TLS13TicketInfo
tinfo Int
maxSize ByteString
psk
let mgr :: SessionManager
mgr = Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ ServerParams -> Shared
serverShared ServerParams
sparams
SessionManager -> ByteString -> SessionData -> IO ()
sessionEstablish SessionManager
mgr ByteString
sessionId SessionData
sdata
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sessionId, TLS13TicketInfo -> Word32
ageAdd TLS13TicketInfo
tinfo)
createNewSessionTicket :: Word32 -> Word32 -> ByteString -> ByteString -> p -> Handshake13
createNewSessionTicket Word32
life Word32
add ByteString
nonce ByteString
label p
maxSize =
Word32
-> Word32
-> ByteString
-> ByteString
-> [ExtensionRaw]
-> Handshake13
NewSessionTicket13 Word32
life Word32
add ByteString
nonce ByteString
label [ExtensionRaw]
extensions
where
tedi :: ByteString
tedi = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> EarlyDataIndication
EarlyDataIndication forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral p
maxSize
extensions :: [ExtensionRaw]
extensions = [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_EarlyData ByteString
tedi]
toSeconds :: a -> a
toSeconds a
i | a
i forall a. Ord a => a -> a -> Bool
< a
0 = a
0
| a
i forall a. Ord a => a -> a -> Bool
> a
604800 = a
604800
| Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i
dhModes :: [PskKexMode]
dhModes = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_PskKeyExchangeModes [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
MsgTClientHello of
Just (PskKeyExchangeModes [PskKexMode]
ms) -> [PskKexMode]
ms
Maybe PskKeyExchangeModes
Nothing -> []
expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool
expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool
expectCertificate (Certificate13 ByteString
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
certCtx forall a. Eq a => a -> a -> Bool
/= ByteString
"") 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
"certificate request context MUST be empty", Bool
True, AlertDescription
IllegalParameter)
ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs
expectCertificate Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (forall a. a -> Maybe a
Just String
"certificate 13")
hashSize :: Int
hashSize = Hash -> Int
hashDigestSize Hash
usedHash
zero :: ByteString
zero = Int -> CompressionID -> ByteString
B.replicate Int
hashSize CompressionID
0
expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx ByteString
hChCc (CertVerify13 HashAndSignatureAlgorithm
sigAlg ByteString
sig) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
certs :: CertificateChain
certs@(CertificateChain [SignedExact Certificate]
cc) <- forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
"finished 13 message expected"
PubKey
pubkey <- case [SignedExact Certificate]
cc of
[] -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"client certificate missing", Bool
True, AlertDescription
HandshakeFailure)
SignedExact Certificate
c:[SignedExact Certificate]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Certificate -> PubKey
certPubKey forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c
Version
ver <- 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
Bool
verif <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> ByteString
-> m Bool
checkCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
sigAlg ByteString
sig ByteString
hChCc
ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif
expectCertVerify ServerParams
_ Context
_ ByteString
_ Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (forall a. a -> Maybe a
Just String
"certificate verify 13")
helloRetryRequest :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> IO ()
helloRetryRequest :: ServerParams
-> Context
-> Version
-> Cipher
-> [ExtensionRaw]
-> [Group]
-> Session
-> IO ()
helloRetryRequest ServerParams
sparams Context
ctx Version
chosenVersion Cipher
usedCipher [ExtensionRaw]
exts [Group]
serverGroups Session
clientSession = do
Bool
twice <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
twice 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
"Hello retry not allowed again", Bool
True, AlertDescription
HandshakeFailure)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> TLSSt ()
setTLS13HRR Bool
True
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
usedCipher
let clientGroups :: [Group]
clientGroups = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_NegotiatedGroups [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
MsgTClientHello of
Just (NegotiatedGroups [Group]
gs) -> [Group]
gs
Maybe NegotiatedGroups
Nothing -> []
possibleGroups :: [Group]
possibleGroups = [Group]
serverGroups forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
clientGroups
case [Group]
possibleGroups of
[] -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"no group in common with the client for HRR", Bool
True, AlertDescription
HandshakeFailure)
Group
g:[Group]
_ -> do
let serverKeyShare :: ByteString
serverKeyShare = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Group -> KeyShare
KeyShareHRR Group
g
selectedVersion :: ByteString
selectedVersion = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
chosenVersion
extensions :: [ExtensionRaw]
extensions = [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_KeyShare ByteString
serverKeyShare
,ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_SupportedVersions ByteString
selectedVersion]
hrr :: Handshake13
hrr = ServerRandom
-> Session -> ExtensionID -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
hrrRandom Session
clientSession (Cipher -> ExtensionID
cipherID Cipher
usedCipher) [ExtensionRaw]
extensions
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
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ do
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
hrr]
forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
ServerParams -> Context -> IO ()
handshakeServer ServerParams
sparams Context
ctx
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
findHighestVersionFrom Version
clientVersion [Version]
allowedVersions =
case forall a. (a -> Bool) -> [a] -> [a]
filter (Version
clientVersion forall a. Ord a => a -> a -> Bool
>=) forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. a -> Down a
Down [Version]
allowedVersions of
[] -> forall a. Maybe a
Nothing
Version
v:[Version]
_ -> forall a. a -> Maybe a
Just Version
v
getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers ServerParams
sparams Credentials
creds Credentials
sigCreds = forall a. (a -> Bool) -> [a] -> [a]
filter Cipher -> Bool
authorizedCKE (Supported -> [Cipher]
supportedCiphers forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams)
where authorizedCKE :: Cipher -> Bool
authorizedCKE Cipher
cipher =
case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
CipherKeyExchangeType
CipherKeyExchange_RSA -> Bool
canEncryptRSA
CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> Bool
True
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> Bool
canSignRSA
CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> Bool
canSignDSS
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Bool
canSignRSA
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Bool
canSignECDSA
CipherKeyExchangeType
CipherKeyExchange_DH_DSS -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_DH_RSA -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_ECDH_ECDSA -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_ECDH_RSA -> Bool
False
CipherKeyExchangeType
CipherKeyExchange_TLS13 -> Bool
False
canSignDSS :: Bool
canSignDSS = KeyExchangeSignatureAlg
KX_DSS forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
canSignRSA :: Bool
canSignRSA = KeyExchangeSignatureAlg
KX_RSA forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
canSignECDSA :: Bool
canSignECDSA = KeyExchangeSignatureAlg
KX_ECDSA forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
canEncryptRSA :: Bool
canEncryptRSA = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Credentials -> Maybe Credential
credentialsFindForDecrypting Credentials
creds
signingAlgs :: [KeyExchangeSignatureAlg]
signingAlgs = Credentials -> [KeyExchangeSignatureAlg]
credentialsListSigningAlgorithms Credentials
sigCreds
findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version
findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version
findHighestVersionFrom13 [Version]
clientVersions [Version]
serverVersions = case [Version]
svs forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Version]
cvs of
[] -> forall a. Maybe a
Nothing
Version
v:[Version]
_ -> forall a. a -> Maybe a
Just Version
v
where
svs :: [Version]
svs = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. a -> Down a
Down [Version]
serverVersions
cvs :: [Version]
cvs = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. a -> Down a
Down forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
> Version
SSL3) [Version]
clientVersions
applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol Context
ctx [ExtensionRaw]
exts ServerParams
sparams = do
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
MsgTClientHello of
Maybe ApplicationLayerProtocolNegotiation
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (ApplicationLayerProtocolNegotiation [ByteString]
protos) -> do
case ServerHooks -> Maybe ([ByteString] -> IO ByteString)
onALPNClientSuggest forall a b. (a -> b) -> a -> b
$ ServerParams -> ServerHooks
serverHooks ServerParams
sparams of
Just [ByteString] -> IO ByteString
io -> do
ByteString
proto <- [ByteString] -> IO ByteString
io [ByteString]
protos
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
proto forall a. Eq a => a -> a -> Bool
== ByteString
"") 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
"no supported application protocols", Bool
True, AlertDescription
NoApplicationProtocol)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
Bool -> TLSSt ()
setExtensionALPN Bool
True
ByteString -> TLSSt ()
setNegotiatedProtocol ByteString
proto
forall (m :: * -> *) a. Monad m => a -> m a
return [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ApplicationLayerProtocolNegotiation
(forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ [ByteString] -> ApplicationLayerProtocolNegotiation
ApplicationLayerProtocolNegotiation [ByteString
proto]) ]
Maybe ([ByteString] -> IO ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]
-> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 [HashAndSignatureAlgorithm]
hss0 Credentials
creds = [HashAndSignatureAlgorithm]
-> Maybe (Credential, HashAndSignatureAlgorithm)
loop [HashAndSignatureAlgorithm]
hss0
where
loop :: [HashAndSignatureAlgorithm]
-> Maybe (Credential, HashAndSignatureAlgorithm)
loop [] = forall a. Maybe a
Nothing
loop (HashAndSignatureAlgorithm
hs:[HashAndSignatureAlgorithm]
hss) = case HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
credentialsFindForSigning13' HashAndSignatureAlgorithm
hs Credentials
creds of
Maybe Credential
Nothing -> [HashAndSignatureAlgorithm]
-> Maybe (Credential, HashAndSignatureAlgorithm)
loop [HashAndSignatureAlgorithm]
hss
Just Credential
cred -> forall a. a -> Maybe a
Just (Credential
cred, HashAndSignatureAlgorithm
hs)
credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
credentialsFindForSigning13' HashAndSignatureAlgorithm
sigAlg (Credentials [Credential]
l) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Credential -> Bool
forSigning [Credential]
l
where
forSigning :: Credential -> Bool
forSigning Credential
cred = case Credential -> Maybe PubKey
credentialDigitalSignatureKey Credential
cred of
Maybe PubKey
Nothing -> Bool
False
Just PubKey
pub -> PubKey
pub PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible13` HashAndSignatureAlgorithm
sigAlg
clientCertificate :: ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate :: ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs = do
forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx (Hooks -> CertificateChain -> IO ()
`hookRecvCertificates` CertificateChain
certs)
CertificateUsage
usage <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (SomeException -> IO a) -> IO a
catchException (ServerHooks -> CertificateChain -> IO CertificateUsage
onClientCertificate (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) CertificateChain
certs) SomeException -> IO CertificateUsage
rejectOnException
case CertificateUsage
usage of
CertificateUsage
CertificateUsageAccept -> forall (m :: * -> *).
MonadIO m =>
[ExtKeyUsageFlag] -> CertificateChain -> m ()
verifyLeafKeyUsage [ExtKeyUsageFlag
KeyUsage_digitalSignature] CertificateChain
certs
CertificateUsageReject CertificateRejectReason
reason -> forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
certificateRejected CertificateRejectReason
reason
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ CertificateChain -> HandshakeM ()
setClientCertChain CertificateChain
certs
clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif = do
if Bool
verif then do
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Bool
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ServerHooks -> IO Bool
onUnverifiedClientCert (ServerParams -> ServerHooks
serverHooks ServerParams
sparams)
if Bool
res then do
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
else forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"verification failed"
newCertReqContext :: Context -> IO CertReqContext
newCertReqContext :: Context -> IO ByteString
newCertReqContext Context
ctx = Context -> Int -> IO ByteString
getStateRNG Context
ctx Int
32
requestCertificateServer :: ServerParams -> Context -> IO Bool
requestCertificateServer :: ServerParams -> Context -> IO Bool
requestCertificateServer ServerParams
sparams Context
ctx = do
Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
Bool
supportsPHA <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getClientSupportsPHA
let ok :: Bool
ok = Bool
tls13 Bool -> Bool -> Bool
&& Bool
supportsPHA
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok forall a b. (a -> b) -> a -> b
$ do
ByteString
certReqCtx <- Context -> IO ByteString
newCertReqContext Context
ctx
let certReq :: Handshake13
certReq = ServerParams -> Context -> ByteString -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx
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 ()
addCertRequest13 Context
ctx Handshake13
certReq
Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
certReq]
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok
postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthServerWith ServerParams
sparams Context
ctx h :: Handshake13
h@(Certificate13 ByteString
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = do
Maybe Handshake13
mCertReq <- Context -> ByteString -> IO (Maybe Handshake13)
getCertRequest13 Context
ctx ByteString
certCtx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Handshake13
mCertReq) 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
"unknown certificate request context", Bool
True, AlertDescription
DecodeError)
let certReq :: Handshake13
certReq = forall a. String -> Maybe a -> a
fromJust String
"certReq" Maybe Handshake13
mCertReq
ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
Saved (Maybe HandshakeState)
baseHState <- Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx
Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
certReq
Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
(Hash
usedHash, Cipher
_, CryptLevel
level, ByteString
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getRxState 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
"tried post-handshake authentication without application traffic secret", Bool
True, AlertDescription
InternalError)
let expectFinished :: ByteString -> Handshake13 -> IO ()
expectFinished ByteString
hChBeforeCf (Finished13 ByteString
verifyData) = do
forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
checkFinished Context
ctx Hash
usedHash ByteString
applicationSecretN ByteString
hChBeforeCf ByteString
verifyData
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Context
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
restoreHState Context
ctx Saved (Maybe HandshakeState)
baseHState
expectFinished ByteString
_ Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (forall a. a -> Maybe a
Just String
"finished 13")
if CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs
then Context -> [PendingAction] -> IO ()
setPendingActions Context
ctx [ Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
False ByteString -> Handshake13 -> IO ()
expectFinished ]
else Context -> [PendingAction] -> IO ()
setPendingActions Context
ctx [ Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
False (forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx)
, Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
False ByteString -> Handshake13 -> IO ()
expectFinished
]
postHandshakeAuthServerWith ServerParams
_ 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 postHandshakeAuthServerWith", Bool
True, AlertDescription
UnexpectedMessage)
contextSync :: Context -> ServerState -> IO ()
contextSync :: Context -> ServerState -> IO ()
contextSync Context
ctx ServerState
ctl = case Context -> HandshakeSync
ctxHandshakeSync Context
ctx of
HandshakeSync Context -> ClientState -> IO ()
_ Context -> ServerState -> IO ()
sync -> Context -> ServerState -> IO ()
sync Context
ctx ServerState
ctl