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