{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.TLS.Handshake.Server.TLS13 (
recvClientSecondFlight13,
postHandshakeAuthServerWith,
) where
import Control.Monad.State.Strict
import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Extension
import Network.TLS.Handshake.Common hiding (expectFinished)
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.Session
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.X509
recvClientSecondFlight13
:: ServerParams
-> Context
-> ( SecretTriple ApplicationSecret
, ClientTrafficSecret HandshakeSecret
, Bool
, Bool
)
-> CH
-> IO ()
recvClientSecondFlight13 :: ServerParams
-> Context
-> (SecretTriple ApplicationSecret,
ClientTrafficSecret HandshakeSecret, Bool, Bool)
-> CH
-> IO ()
recvClientSecondFlight13 ServerParams
sparams Context
ctx (SecretTriple ApplicationSecret
appKey, ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, Bool
authenticated, Bool
rtt0OK) CH{[CipherID]
[ExtensionRaw]
Session
chSession :: Session
chCiphers :: [CipherID]
chExtensions :: [ExtensionRaw]
chSession :: CH -> Session
chCiphers :: CH -> [CipherID]
chExtensions :: CH -> [ExtensionRaw]
..} = do
Millisecond
sfSentTime <- IO Millisecond
getCurrentTimeFromBase
let expectFinished' :: ByteString -> Handshake13 -> RecvHandshake13M IO ()
expectFinished' =
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> ByteString
-> Handshake13
-> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> ByteString
-> Handshake13
-> m ()
expectFinished ServerParams
sparams Context
ctx [ExtensionRaw]
chExtensions SecretTriple ApplicationSecret
appKey ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Millisecond
sfSentTime
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)
-> RecvHandshake13M IO Bool)
-> (Handshake13 -> RecvHandshake13M IO Bool)
-> RecvHandshake13M IO Bool
forall a b. (a -> b) -> a -> b
$ ServerParams -> Context -> Handshake13 -> RecvHandshake13M IO Bool
forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> Handshake13 -> m Bool
expectCertificate ServerParams
sparams Context
ctx
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 ()
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 -> [PendingRecvAction] -> IO ()
setPendingRecvActions
Context
ctx
[ Bool -> (Handshake13 -> IO ()) -> PendingRecvAction
PendingRecvAction Bool
True ((Handshake13 -> IO ()) -> PendingRecvAction)
-> (Handshake13 -> IO ()) -> PendingRecvAction
forall a b. (a -> b) -> a -> b
$ Context
-> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()
expectEndOfEarlyData Context
ctx ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
, Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingRecvAction
PendingRecvActionHash Bool
True ((ByteString -> Handshake13 -> IO ()) -> PendingRecvAction)
-> (ByteString -> Handshake13 -> IO ()) -> PendingRecvAction
forall a b. (a -> b) -> a -> b
$
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> ByteString
-> Handshake13
-> IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> ByteString
-> Handshake13
-> m ()
expectFinished ServerParams
sparams Context
ctx [ExtensionRaw]
chExtensions SecretTriple ApplicationSecret
appKey ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Millisecond
sfSentTime
]
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 ()
expectFinished'
Context -> RecvHandshake13M IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
expectFinished
:: MonadIO m
=> ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Word64
-> ByteString
-> Handshake13
-> m ()
expectFinished :: forall (m :: * -> *).
MonadIO m =>
ServerParams
-> Context
-> [ExtensionRaw]
-> SecretTriple ApplicationSecret
-> ClientTrafficSecret HandshakeSecret
-> Millisecond
-> ByteString
-> Handshake13
-> m ()
expectFinished ServerParams
sparams Context
ctx [ExtensionRaw]
exts SecretTriple ApplicationSecret
appKey ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Millisecond
sfSentTime ByteString
hChBeforeCf (Finished13 ByteString
verifyData) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Context -> (TLS13State -> TLS13State) -> IO ()
modifyTLS13State Context
ctx ((TLS13State -> TLS13State) -> IO ())
-> (TLS13State -> TLS13State) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TLS13State
st -> TLS13State
st{tls13stRecvCF = True}
(Hash
usedHash, Cipher
usedCipher, CryptLevel
_, ByteString
_) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getRxRecordState Context
ctx
let ClientTrafficSecret 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 ()
handshakeDone13 Context
ctx
Context
-> Hash -> Cipher -> ClientTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret ApplicationSecret
clientApplicationSecret0
ServerParams
-> Context
-> Cipher
-> [ExtensionRaw]
-> BaseSecret ApplicationSecret
-> Millisecond
-> IO ()
sendNewSessionTicket ServerParams
sparams Context
ctx Cipher
usedCipher [ExtensionRaw]
exts BaseSecret ApplicationSecret
applicationSecret Millisecond
sfSentTime
where
applicationSecret :: BaseSecret ApplicationSecret
applicationSecret = SecretTriple ApplicationSecret -> BaseSecret ApplicationSecret
forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple ApplicationSecret
appKey
clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
clientApplicationSecret0 = SecretTriple ApplicationSecret
-> ClientTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey
expectFinished ServerParams
_ Context
_ [ExtensionRaw]
_ SecretTriple ApplicationSecret
_ ClientTrafficSecret HandshakeSecret
_ Millisecond
_ ByteString
_ 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 String
"finished 13")
expectEndOfEarlyData
:: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()
expectEndOfEarlyData :: Context
-> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()
expectEndOfEarlyData Context
ctx ClientTrafficSecret HandshakeSecret
clientHandshakeSecret Handshake13
EndOfEarlyData13 = do
(Hash
usedHash, Cipher
usedCipher, CryptLevel
_, ByteString
_) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getRxRecordState Context
ctx
Context
-> Hash -> Cipher -> ClientTrafficSecret HandshakeSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
expectEndOfEarlyData Context
_ ClientTrafficSecret HandshakeSecret
_ 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 String
"end of early data")
expectCertificate
:: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool
expectCertificate :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> Handshake13 -> m Bool
expectCertificate ServerParams
sparams Context
ctx (Certificate13 ByteString
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
certCtx ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (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 -> AlertDescription -> TLSError
Error_Protocol String
"certificate request context MUST be empty" AlertDescription
IllegalParameter
ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
Bool -> IO Bool
forall a. a -> IO a
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 ServerParams
_ Context
_ Handshake13
hs = String -> Maybe String -> m 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 String
"certificate 13")
sendNewSessionTicket
:: ServerParams
-> Context
-> Cipher
-> [ExtensionRaw]
-> BaseSecret ApplicationSecret
-> Word64
-> IO ()
sendNewSessionTicket :: ServerParams
-> Context
-> Cipher
-> [ExtensionRaw]
-> BaseSecret ApplicationSecret
-> Millisecond
-> IO ()
sendNewSessionTicket ServerParams
sparams Context
ctx Cipher
usedCipher [ExtensionRaw]
exts BaseSecret ApplicationSecret
applicationSecret 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 Int
32
BaseSecret ResumptionSecret
resumptionSecret <- Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret Context
ctx CipherChoice
choice BaseSecret ApplicationSecret
applicationSecret
let life :: Second
life = Int -> Second
forall {a} {a}. (Num a, Integral a) => a -> a
adjustLifetime (Int -> Second) -> Int -> Second
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
resumptionSecret ByteString
nonce
(ByteString
identity, Second
add) <- Second
-> ByteString -> Int -> Millisecond -> IO (ByteString, Second)
generateSession Second
life ByteString
psk Int
rtt0max Millisecond
rtt
let nst :: Handshake13
nst = Second -> Second -> ByteString -> ByteString -> Int -> Handshake13
forall {p}.
Integral p =>
Second -> Second -> ByteString -> ByteString -> p -> Handshake13
createNewSessionTicket Second
life Second
add ByteString
nonce ByteString
identity 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
choice :: CipherChoice
choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
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
sendNST :: Bool
sendNST = PskKexMode
PSK_DHE_KE PskKexMode -> [PskKexMode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes
dhModes :: [PskKexMode]
dhModes = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_PskKeyExchangeModes [ExtensionRaw]
exts
Maybe ByteString
-> (ByteString -> Maybe PskKeyExchangeModes)
-> Maybe PskKeyExchangeModes
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 [PskKexMode]
ms) -> [PskKexMode]
ms
Maybe PskKeyExchangeModes
Nothing -> []
generateSession :: Second
-> ByteString -> Int -> Millisecond -> IO (ByteString, Second)
generateSession Second
life ByteString
psk Int
maxSize Millisecond
rtt = do
Session (Just ByteString
sessionId) <- Context -> IO Session
newSession Context
ctx
TLS13TicketInfo
tinfo <- Second
-> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Second
life (Context -> Either Context Second
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
Maybe ByteString
mticket <- SessionManager
-> ByteString -> SessionData -> IO (Maybe ByteString)
sessionEstablish SessionManager
mgr ByteString
sessionId SessionData
sdata
let identity :: ByteString
identity = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
sessionId Maybe ByteString
mticket
(ByteString, Second) -> IO (ByteString, Second)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
identity, TLS13TicketInfo -> Second
ageAdd TLS13TicketInfo
tinfo)
createNewSessionTicket :: Second -> Second -> ByteString -> ByteString -> p -> Handshake13
createNewSessionTicket Second
life Second
add ByteString
nonce ByteString
identity p
maxSize =
Second
-> Second
-> ByteString
-> ByteString
-> [ExtensionRaw]
-> Handshake13
NewSessionTicket13 Second
life Second
add ByteString
nonce ByteString
identity [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 Second -> EarlyDataIndication
EarlyDataIndication (Maybe Second -> EarlyDataIndication)
-> Maybe Second -> EarlyDataIndication
forall a b. (a -> b) -> a -> b
$ Second -> Maybe Second
forall a. a -> Maybe a
Just (Second -> Maybe Second) -> Second -> Maybe Second
forall a b. (a -> b) -> a -> b
$ p -> Second
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
maxSize
extensions :: [ExtensionRaw]
extensions = [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_EarlyData ByteString
tedi]
adjustLifetime :: a -> a
adjustLifetime a
i
| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = a
0
| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
604800 = a
604800
| Bool
otherwise = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i
expectCertVerify
:: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx ByteString
hChCc (CertVerify13 HashAndSignatureAlgorithm
sigAlg ByteString
sig) = IO () -> m ()
forall a. IO a -> m a
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 [SignedExact Certificate]
cc) <-
Context -> String -> IO CertificateChain
forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
"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 -> AlertDescription -> TLSError
Error_Protocol String
"client certificate missing" AlertDescription
HandshakeFailure
SignedExact Certificate
c : [SignedExact Certificate]
_ -> PubKey -> IO PubKey
forall a. a -> IO a
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 ServerParams
_ Context
_ ByteString
_ 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 String
"certificate verify 13")
clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif = do
if Bool
verif
then do
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Bool
res <- IO Bool -> IO Bool
forall a. IO a -> IO a
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 String
"verification failed"
postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthServerWith ServerParams
sparams Context
ctx h :: Handshake13
h@(Certificate13 ByteString
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = do
Maybe Handshake13
mCertReq <- Context -> ByteString -> IO (Maybe Handshake13)
getCertRequest13 Context
ctx ByteString
certCtx
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 -> AlertDescription -> TLSError
Error_Protocol String
"unknown certificate request context" AlertDescription
DecodeError
let certReq :: Handshake13
certReq = Maybe Handshake13 -> Handshake13
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handshake13
mCertReq
ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
Saved (Maybe HandshakeState)
baseHState <- Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx
Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
certReq
Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
(Hash
usedHash, Cipher
_, CryptLevel
level, ByteString
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getRxRecordState 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 -> AlertDescription -> TLSError
Error_Protocol
String
"tried post-handshake authentication without application traffic secret"
AlertDescription
InternalError
let expectFinished' :: ByteString -> Handshake13 -> IO ()
expectFinished' ByteString
hChBeforeCf (Finished13 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' ByteString
_ 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 String
"finished 13")
if CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs
then Context -> [PendingRecvAction] -> IO ()
setPendingRecvActions Context
ctx [Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingRecvAction
PendingRecvActionHash Bool
False ByteString -> Handshake13 -> IO ()
expectFinished']
else
Context -> [PendingRecvAction] -> IO ()
setPendingRecvActions
Context
ctx
[ Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingRecvAction
PendingRecvActionHash 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 ()) -> PendingRecvAction
PendingRecvActionHash Bool
False ByteString -> Handshake13 -> IO ()
expectFinished'
]
postHandshakeAuthServerWith ServerParams
_ Context
_ Handshake13
_ =
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol
String
"unexpected handshake message received in postHandshakeAuthServerWith"
AlertDescription
UnexpectedMessage