{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.TLS.Handshake.Common13 (
makeFinished,
checkFinished,
makeServerKeyShare,
makeClientKeyShare,
fromServerKeyShare,
makeCertVerify,
checkCertVerify,
makePSKBinder,
replacePSKBinder,
sendChangeCipherSpec13,
handshakeDone13,
makeCertRequest,
createTLS13TicketInfo,
ageToObfuscatedAge,
isAgeValid,
getAge,
checkFreshness,
getCurrentTimeFromBase,
getSessionData13,
isHashSignatureValid13,
safeNonNegative32,
RecvHandshake13M,
runRecvHandshake13,
recvHandshake13,
recvHandshake13hash,
CipherChoice (..),
makeCipherChoice,
initEarlySecret,
calculateEarlySecret,
calculateHandshakeSecret,
calculateApplicationSecret,
calculateResumptionSecret,
derivePSK,
checkKeyShareKeyLength,
setRTT,
) where
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.UnixTime
import Foreign.C.Types (CTime (..))
import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import qualified Network.TLS.Crypto.IES as IES
import Network.TLS.Extension
import Network.TLS.Handshake.Certificate (extractCAname)
import Network.TLS.Handshake.Common (unexpected)
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Process (processHandshake13)
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.KeySchedule
import Network.TLS.MAC
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.Wire
import Control.Concurrent.MVar
import Control.Monad.State.Strict
makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13
makeFinished :: forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> m Handshake13
makeFinished Context
ctx Hash
usedHash ByteString
baseKey = do
verifyData <-
ByteString -> VerifyData
VerifyData (ByteString -> VerifyData)
-> (ByteString -> ByteString) -> ByteString -> VerifyData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> ByteString -> ByteString -> ByteString
makeVerifyData Hash
usedHash ByteString
baseKey (ByteString -> VerifyData) -> m ByteString -> m VerifyData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> m ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData
pure $ Finished13 verifyData
checkFinished
:: MonadIO m => Context -> Hash -> ByteString -> ByteString -> VerifyData -> m ()
checkFinished :: forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> ByteString -> VerifyData -> m ()
checkFinished Context
ctx Hash
usedHash ByteString
baseKey ByteString
hashValue vd :: VerifyData
vd@(VerifyData ByteString
verifyData) = do
let verifyData' :: ByteString
verifyData' = Hash -> ByteString -> ByteString -> ByteString
makeVerifyData Hash
usedHash ByteString
baseKey ByteString
hashValue
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
verifyData Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Int
B.length ByteString
verifyData') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
TLSError -> m ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m ()) -> TLSError -> m ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol String
"broken Finished" AlertDescription
DecodeError
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
verifyData' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
verifyData) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"cannot verify finished"
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
$ Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ VerifyData -> TLSSt ()
setVerifyDataForRecv VerifyData
vd
makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString
makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString
makeVerifyData Hash
usedHash ByteString
baseKey = Hash -> ByteString -> ByteString -> ByteString
hmac Hash
usedHash ByteString
finishedKey
where
hashSize :: Int
hashSize = Hash -> Int
hashDigestSize Hash
usedHash
finishedKey :: ByteString
finishedKey = Hash -> ByteString -> ByteString -> ByteString -> Int -> ByteString
hkdfExpandLabel Hash
usedHash ByteString
baseKey ByteString
"finished" ByteString
"" Int
hashSize
makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)
makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)
makeServerKeyShare Context
ctx (KeyShareEntry Group
grp ByteString
wcpub) = case Either CryptoError GroupPublic
ecpub of
Left CryptoError
e -> TLSError -> IO (ByteString, KeyShareEntry)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (ByteString, KeyShareEntry))
-> TLSError -> IO (ByteString, KeyShareEntry)
forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol (CryptoError -> String
forall a. Show a => a -> String
show CryptoError
e) AlertDescription
IllegalParameter
Right GroupPublic
cpub -> do
ecdhePair <- Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))
generateECDHEShared Context
ctx GroupPublic
cpub
case ecdhePair of
Maybe (GroupPublic, GroupKey)
Nothing -> TLSError -> IO (ByteString, KeyShareEntry)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (ByteString, KeyShareEntry))
-> TLSError -> IO (ByteString, KeyShareEntry)
forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
msgInvalidPublic AlertDescription
IllegalParameter
Just (GroupPublic
spub, GroupKey
share) ->
let wspub :: ByteString
wspub = GroupPublic -> ByteString
IES.encodeGroupPublic GroupPublic
spub
serverKeyShare :: KeyShareEntry
serverKeyShare = Group -> ByteString -> KeyShareEntry
KeyShareEntry Group
grp ByteString
wspub
in (ByteString, KeyShareEntry) -> IO (ByteString, KeyShareEntry)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GroupKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert GroupKey
share, KeyShareEntry
serverKeyShare)
where
ecpub :: Either CryptoError GroupPublic
ecpub = Group -> ByteString -> Either CryptoError GroupPublic
IES.decodeGroupPublic Group
grp ByteString
wcpub
msgInvalidPublic :: String
msgInvalidPublic = String
"invalid client " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Group -> String
forall a. Show a => a -> String
show Group
grp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" public key"
makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry)
makeClientKeyShare :: Context -> Group -> IO (GroupPrivate, KeyShareEntry)
makeClientKeyShare Context
ctx Group
grp = do
(cpri, cpub) <- Context -> Group -> IO (GroupPrivate, GroupPublic)
generateECDHE Context
ctx Group
grp
let wcpub = GroupPublic -> ByteString
IES.encodeGroupPublic GroupPublic
cpub
clientKeyShare = Group -> ByteString -> KeyShareEntry
KeyShareEntry Group
grp ByteString
wcpub
return (cpri, clientKeyShare)
fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString
fromServerKeyShare :: KeyShareEntry -> GroupPrivate -> IO ByteString
fromServerKeyShare (KeyShareEntry Group
grp ByteString
wspub) GroupPrivate
cpri = case Either CryptoError GroupPublic
espub of
Left CryptoError
e -> TLSError -> IO ByteString
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ByteString) -> TLSError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol (CryptoError -> String
forall a. Show a => a -> String
show CryptoError
e) AlertDescription
IllegalParameter
Right GroupPublic
spub -> case GroupPublic -> GroupPrivate -> Maybe GroupKey
IES.groupGetShared GroupPublic
spub GroupPrivate
cpri of
Just GroupKey
shared -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ GroupKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert GroupKey
shared
Maybe GroupKey
Nothing ->
TLSError -> IO ByteString
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ByteString) -> TLSError -> IO ByteString
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol String
"cannot generate a shared secret on (EC)DH" AlertDescription
IllegalParameter
where
espub :: Either CryptoError GroupPublic
espub = Group -> ByteString -> Either CryptoError GroupPublic
IES.decodeGroupPublic Group
grp ByteString
wspub
serverContextString :: ByteString
serverContextString :: ByteString
serverContextString = ByteString
"TLS 1.3, server CertificateVerify"
clientContextString :: ByteString
clientContextString :: ByteString
clientContextString = ByteString
"TLS 1.3, client CertificateVerify"
makeCertVerify
:: MonadIO m
=> Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Handshake13
makeCertVerify :: forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Handshake13
makeCertVerify Context
ctx PubKey
pub HashAndSignatureAlgorithm
hs ByteString
hashValue = do
role <- IO Role -> m Role
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Role -> m Role) -> IO Role -> m Role
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
let ctxStr
| Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole = ByteString
clientContextString
| Bool
otherwise = ByteString
serverContextString
target = ByteString -> ByteString -> ByteString
makeTarget ByteString
ctxStr ByteString
hashValue
CertVerify13 . DigitallySigned hs <$> sign ctx pub hs target
checkCertVerify
:: MonadIO m
=> Context
-> PubKey
-> HashAndSignatureAlgorithm
-> Signature
-> ByteString
-> m Bool
checkCertVerify :: forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> ByteString
-> m Bool
checkCertVerify Context
ctx PubKey
pub HashAndSignatureAlgorithm
hs ByteString
signature ByteString
hashValue
| PubKey
pub PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible13` HashAndSignatureAlgorithm
hs = 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
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
let ctxStr
| Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole = ByteString
serverContextString
| Bool
otherwise = ByteString
clientContextString
target = ByteString -> ByteString -> ByteString
makeTarget ByteString
ctxStr ByteString
hashValue
sigParams = PubKey -> HashAndSignatureAlgorithm -> SignatureParams
signatureParams PubKey
pub HashAndSignatureAlgorithm
hs
checkHashSignatureValid13 hs
checkSupportedHashSignature ctx hs
verifyPublic ctx sigParams target signature
| Bool
otherwise = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
makeTarget :: ByteString -> ByteString -> ByteString
makeTarget :: ByteString -> ByteString -> ByteString
makeTarget ByteString
contextString ByteString
hashValue = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
ByteString -> Put
putBytes (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Int -> CompressionID -> ByteString
B.replicate Int
64 CompressionID
32
ByteString -> Put
putBytes ByteString
contextString
Putter CompressionID
putWord8 CompressionID
0
ByteString -> Put
putBytes ByteString
hashValue
sign
:: MonadIO m
=> Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Signature
sign :: forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m ByteString
sign Context
ctx PubKey
pub HashAndSignatureAlgorithm
hs ByteString
target = IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
let sigParams = PubKey -> HashAndSignatureAlgorithm -> SignatureParams
signatureParams PubKey
pub HashAndSignatureAlgorithm
hs
signPrivate ctx role sigParams target
makePSKBinder
:: Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe ByteString
-> IO ByteString
makePSKBinder :: Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe ByteString
-> IO ByteString
makePSKBinder Context
ctx (BaseSecret ByteString
sec) Hash
usedHash Int
truncLen Maybe ByteString
mch = do
rmsgs <- case Maybe ByteString
mch of
Just ByteString
ch -> (ByteString -> ByteString
trunc ByteString
ch ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> HandshakeM [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM [ByteString]
getHandshakeMessagesRev
Maybe ByteString
Nothing -> do
ch : rs <- Context -> HandshakeM [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM [ByteString]
getHandshakeMessagesRev
return $ trunc ch : rs
let hChTruncated = Hash -> ByteString -> ByteString
hash Hash
usedHash (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
rmsgs
binderKey = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
sec ByteString
"res binder" (Hash -> ByteString -> ByteString
hash Hash
usedHash ByteString
"")
return $ makeVerifyData usedHash binderKey hChTruncated
where
trunc :: ByteString -> ByteString
trunc ByteString
x = Int -> ByteString -> ByteString
B.take Int
takeLen ByteString
x
where
totalLen :: Int
totalLen = ByteString -> Int
B.length ByteString
x
takeLen :: Int
takeLen = Int
totalLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
truncLen
replacePSKBinder :: ByteString -> [ByteString] -> ByteString
replacePSKBinder :: ByteString -> [ByteString] -> ByteString
replacePSKBinder ByteString
pskz [ByteString]
bds = ByteString
tLidentities ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
binders
where
tLidentities :: ByteString
tLidentities = Int -> ByteString -> ByteString
B.take (ByteString -> Int
B.length ByteString
pskz Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
binders) ByteString
pskz
binders :: ByteString
binders = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Put
putOpaque16 (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut ((ByteString -> Put) -> [ByteString] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> Put
putBinder [ByteString]
bds)
putBinder :: ByteString -> Put
putBinder = ByteString -> Put
putOpaque8
sendChangeCipherSpec13 :: Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 :: forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx = do
sent <- Context -> HandshakeM Bool -> PacketFlightM b Bool
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM Bool -> PacketFlightM b Bool)
-> HandshakeM Bool -> PacketFlightM b Bool
forall a b. (a -> b) -> a -> b
$ do
b <- HandshakeM Bool
getCCS13Sent
unless b $ setCCS13Sent True
return b
unless sent $ loadPacket13 ctx ChangeCipherSpec13
handshakeDone13 :: Context -> IO ()
handshakeDone13 :: Context -> IO ()
handshakeDone13 Context
ctx = do
MVar (Maybe HandshakeState)
-> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Context -> MVar (Maybe HandshakeState)
ctxHandshakeState Context
ctx) ((Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ())
-> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
Maybe HandshakeState
Nothing -> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HandshakeState
forall a. Maybe a
Nothing
Just HandshakeState
hshake ->
Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HandshakeState -> IO (Maybe HandshakeState))
-> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a b. (a -> b) -> a -> b
$
HandshakeState -> Maybe HandshakeState
forall a. a -> Maybe a
Just
(Version -> ClientRandom -> HandshakeState
newEmptyHandshake (HandshakeState -> Version
hstClientVersion HandshakeState
hshake) (HandshakeState -> ClientRandom
hstClientRandom HandshakeState
hshake))
{ hstServerRandom = hstServerRandom hshake
, hstMainSecret = hstMainSecret hshake
, hstSupportedGroup = hstSupportedGroup hshake
, hstHandshakeDigest = hstHandshakeDigest hshake
, hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake
, hstTLS13RTT0Status = hstTLS13RTT0Status hshake
, hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake
}
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
Maybe KeyShare -> TLSSt ()
setTLS13KeyShare Maybe KeyShare
forall a. Maybe a
Nothing
Maybe PreSharedKey -> TLSSt ()
setTLS13PreSharedKey Maybe PreSharedKey
forall a. Maybe a
Nothing
Context -> Established -> IO ()
setEstablished Context
ctx Established
Established
makeCertRequest
:: ServerParams -> Context -> CertReqContext -> Bool -> Handshake13
makeCertRequest :: ServerParams -> Context -> ByteString -> Bool -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx Bool
zlib =
let sigAlgs :: SignatureAlgorithms
sigAlgs = [HashAndSignatureAlgorithm] -> SignatureAlgorithms
SignatureAlgorithms ([HashAndSignatureAlgorithm] -> SignatureAlgorithms)
-> [HashAndSignatureAlgorithm] -> SignatureAlgorithms
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
signatureAlgExt :: Maybe ExtensionRaw
signatureAlgExt = ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ SignatureAlgorithms -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw SignatureAlgorithms
sigAlgs
compCertExt :: Maybe ExtensionRaw
compCertExt
| Bool
zlib = ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ CompressCertificate -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (CompressCertificate -> ExtensionRaw)
-> CompressCertificate -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [CertificateCompressionAlgorithm] -> CompressCertificate
CompressCertificate [CertificateCompressionAlgorithm
CCA_Zlib]
| Bool
otherwise = Maybe ExtensionRaw
forall a. Maybe a
Nothing
caDns :: [DistinguishedName]
caDns = (SignedCertificate -> DistinguishedName)
-> [SignedCertificate] -> [DistinguishedName]
forall a b. (a -> b) -> [a] -> [b]
map SignedCertificate -> DistinguishedName
extractCAname ([SignedCertificate] -> [DistinguishedName])
-> [SignedCertificate] -> [DistinguishedName]
forall a b. (a -> b) -> a -> b
$ ServerParams -> [SignedCertificate]
serverCACertificates ServerParams
sparams
caExt :: Maybe ExtensionRaw
caExt
| [DistinguishedName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DistinguishedName]
caDns = 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
$ CertificateAuthorities -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (CertificateAuthorities -> ExtensionRaw)
-> CertificateAuthorities -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [DistinguishedName] -> CertificateAuthorities
CertificateAuthorities [DistinguishedName]
caDns
crexts :: [ExtensionRaw]
crexts =
[Maybe ExtensionRaw] -> [ExtensionRaw]
forall a. [Maybe a] -> [a]
catMaybes
[ Maybe ExtensionRaw
signatureAlgExt
, Maybe ExtensionRaw
compCertExt
, Maybe ExtensionRaw
caExt
]
in ByteString -> [ExtensionRaw] -> Handshake13
CertRequest13 ByteString
certReqCtx [ExtensionRaw]
crexts
createTLS13TicketInfo
:: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo :: Second
-> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Second
life Either Context Second
ecw Maybe Millisecond
mrtt = do
bTime <- IO Millisecond
getCurrentTimeFromBase
add <- case ecw of
Left Context
ctx -> (Second -> CompressionID -> Second)
-> Second -> ByteString -> Second
forall a. (a -> CompressionID -> a) -> a -> ByteString -> a
B.foldl' Second -> CompressionID -> Second
forall {a} {a}. (Integral a, Num a) => a -> a -> a
(*+) Second
0 (ByteString -> Second) -> IO ByteString -> IO Second
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO ByteString
getStateRNG Context
ctx Int
4
Right Second
ad -> Second -> IO Second
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Second
ad
return $
TLS13TicketInfo
{ lifetime = life
, ageAdd = add
, txrxTime = bTime
, estimatedRTT = mrtt
}
where
a
x *+ :: a -> a -> a
*+ a
y = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
256 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y
ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second
ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second
ageToObfuscatedAge Second
age TLS13TicketInfo{Maybe Millisecond
Second
Millisecond
lifetime :: TLS13TicketInfo -> Second
ageAdd :: TLS13TicketInfo -> Second
txrxTime :: TLS13TicketInfo -> Millisecond
estimatedRTT :: TLS13TicketInfo -> Maybe Millisecond
lifetime :: Second
ageAdd :: Second
txrxTime :: Millisecond
estimatedRTT :: Maybe Millisecond
..} = Second
obfage
where
obfage :: Second
obfage = Second
age Second -> Second -> Second
forall a. Num a => a -> a -> a
+ Second
ageAdd
obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second
obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second
obfuscatedAgeToAge Second
obfage TLS13TicketInfo{Maybe Millisecond
Second
Millisecond
lifetime :: TLS13TicketInfo -> Second
ageAdd :: TLS13TicketInfo -> Second
txrxTime :: TLS13TicketInfo -> Millisecond
estimatedRTT :: TLS13TicketInfo -> Maybe Millisecond
lifetime :: Second
ageAdd :: Second
txrxTime :: Millisecond
estimatedRTT :: Maybe Millisecond
..} = Second
age
where
age :: Second
age = Second
obfage Second -> Second -> Second
forall a. Num a => a -> a -> a
- Second
ageAdd
isAgeValid :: Second -> TLS13TicketInfo -> Bool
isAgeValid :: Second -> TLS13TicketInfo -> Bool
isAgeValid Second
age TLS13TicketInfo{Maybe Millisecond
Second
Millisecond
lifetime :: TLS13TicketInfo -> Second
ageAdd :: TLS13TicketInfo -> Second
txrxTime :: TLS13TicketInfo -> Millisecond
estimatedRTT :: TLS13TicketInfo -> Maybe Millisecond
lifetime :: Second
ageAdd :: Second
txrxTime :: Millisecond
estimatedRTT :: Maybe Millisecond
..} = Second
age Second -> Second -> Bool
forall a. Ord a => a -> a -> Bool
<= Second
lifetime Second -> Second -> Second
forall a. Num a => a -> a -> a
* Second
1000
getAge :: TLS13TicketInfo -> IO Second
getAge :: TLS13TicketInfo -> IO Second
getAge TLS13TicketInfo{Maybe Millisecond
Second
Millisecond
lifetime :: TLS13TicketInfo -> Second
ageAdd :: TLS13TicketInfo -> Second
txrxTime :: TLS13TicketInfo -> Millisecond
estimatedRTT :: TLS13TicketInfo -> Maybe Millisecond
lifetime :: Second
ageAdd :: Second
txrxTime :: Millisecond
estimatedRTT :: Maybe Millisecond
..} = do
let clientReceiveTime :: Millisecond
clientReceiveTime = Millisecond
txrxTime
clientSendTime <- IO Millisecond
getCurrentTimeFromBase
return $ fromIntegral (clientSendTime - clientReceiveTime)
checkFreshness :: TLS13TicketInfo -> Second -> IO Bool
checkFreshness :: TLS13TicketInfo -> Second -> IO Bool
checkFreshness tinfo :: TLS13TicketInfo
tinfo@TLS13TicketInfo{Maybe Millisecond
Second
Millisecond
lifetime :: TLS13TicketInfo -> Second
ageAdd :: TLS13TicketInfo -> Second
txrxTime :: TLS13TicketInfo -> Millisecond
estimatedRTT :: TLS13TicketInfo -> Maybe Millisecond
lifetime :: Second
ageAdd :: Second
txrxTime :: Millisecond
estimatedRTT :: Maybe Millisecond
..} Second
obfAge = do
serverReceiveTime <- IO Millisecond
getCurrentTimeFromBase
let freshness =
if Millisecond
expectedArrivalTime Millisecond -> Millisecond -> Bool
forall a. Ord a => a -> a -> Bool
> Millisecond
serverReceiveTime
then Millisecond
expectedArrivalTime Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
serverReceiveTime
else Millisecond
serverReceiveTime Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
expectedArrivalTime
let tolerance = Millisecond -> Millisecond -> Millisecond
forall a. Ord a => a -> a -> a
max Millisecond
2000 Millisecond
rtt
isFresh = Millisecond
freshness Millisecond -> Millisecond -> Bool
forall a. Ord a => a -> a -> Bool
< Millisecond
tolerance
return $ isAlive && isFresh
where
serverSendTime :: Millisecond
serverSendTime = Millisecond
txrxTime
rtt :: Millisecond
rtt = Maybe Millisecond -> Millisecond
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Millisecond
estimatedRTT
age :: Second
age = Second -> TLS13TicketInfo -> Second
obfuscatedAgeToAge Second
obfAge TLS13TicketInfo
tinfo
expectedArrivalTime :: Millisecond
expectedArrivalTime = Millisecond
serverSendTime Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
+ Millisecond
rtt Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
+ Second -> Millisecond
forall a b. (Integral a, Num b) => a -> b
fromIntegral Second
age
isAlive :: Bool
isAlive = Second -> TLS13TicketInfo -> Bool
isAgeValid Second
age TLS13TicketInfo
tinfo
getCurrentTimeFromBase :: IO Millisecond
getCurrentTimeFromBase :: IO Millisecond
getCurrentTimeFromBase = UnixTime -> Millisecond
millisecondsFromBase (UnixTime -> Millisecond) -> IO UnixTime -> IO Millisecond
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UnixTime
getUnixTime
millisecondsFromBase :: UnixTime -> Millisecond
millisecondsFromBase :: UnixTime -> Millisecond
millisecondsFromBase (UnixTime (CTime Int64
s) Int32
us) =
Int64 -> Millisecond
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int64
s Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
base) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000) Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
+ Int32 -> Millisecond
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
us Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`div` Int32
1000)
where
base :: Int64
base = Int64
1483228800
getSessionData13
:: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
getSessionData13 :: Context
-> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
getSessionData13 Context
ctx Cipher
usedCipher TLS13TicketInfo
tinfo Int
maxSize ByteString
psk = do
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
malpn <- usingState_ ctx getNegotiatedProtocol
sni <- usingState_ ctx getClientSNI
mgrp <- usingHState ctx getSupportedGroup
return
SessionData
{ sessionVersion = ver
, sessionCipher = cipherID usedCipher
, sessionCompression = 0
, sessionClientSNI = sni
, sessionSecret = psk
, sessionGroup = mgrp
, sessionTicketInfo = Just tinfo
, sessionALPN = malpn
, sessionMaxEarlyDataSize = maxSize
, sessionFlags = []
}
safeNonNegative32 :: (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 :: forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 a
x
| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 = a
0
| a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize a
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 = a
x
| Bool
otherwise = a
x a -> a -> a
forall a. Ord a => a -> a -> a
`min` Second -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Second
forall a. Bounded a => a
maxBound :: Word32)
newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)
deriving ((forall a b.
(a -> b) -> RecvHandshake13M m a -> RecvHandshake13M m b)
-> (forall a b. a -> RecvHandshake13M m b -> RecvHandshake13M m a)
-> Functor (RecvHandshake13M m)
forall a b. a -> RecvHandshake13M m b -> RecvHandshake13M m a
forall a b.
(a -> b) -> RecvHandshake13M m a -> RecvHandshake13M m b
forall (m :: * -> *) a b.
Functor m =>
a -> RecvHandshake13M m b -> RecvHandshake13M m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RecvHandshake13M m a -> RecvHandshake13M m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RecvHandshake13M m a -> RecvHandshake13M m b
fmap :: forall a b.
(a -> b) -> RecvHandshake13M m a -> RecvHandshake13M m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RecvHandshake13M m b -> RecvHandshake13M m a
<$ :: forall a b. a -> RecvHandshake13M m b -> RecvHandshake13M m a
Functor, Functor (RecvHandshake13M m)
Functor (RecvHandshake13M m) =>
(forall a. a -> RecvHandshake13M m a)
-> (forall a b.
RecvHandshake13M m (a -> b)
-> RecvHandshake13M m a -> RecvHandshake13M m b)
-> (forall a b c.
(a -> b -> c)
-> RecvHandshake13M m a
-> RecvHandshake13M m b
-> RecvHandshake13M m c)
-> (forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b)
-> (forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m a)
-> Applicative (RecvHandshake13M m)
forall a. a -> RecvHandshake13M m a
forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m a
forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
forall a b.
RecvHandshake13M m (a -> b)
-> RecvHandshake13M m a -> RecvHandshake13M m b
forall a b c.
(a -> b -> c)
-> RecvHandshake13M m a
-> RecvHandshake13M m b
-> RecvHandshake13M m c
forall (m :: * -> *). Monad m => Functor (RecvHandshake13M m)
forall (m :: * -> *) a. Monad m => a -> RecvHandshake13M m a
forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m a
forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m (a -> b)
-> RecvHandshake13M m a -> RecvHandshake13M m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RecvHandshake13M m a
-> RecvHandshake13M m b
-> RecvHandshake13M m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> RecvHandshake13M m a
pure :: forall a. a -> RecvHandshake13M m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m (a -> b)
-> RecvHandshake13M m a -> RecvHandshake13M m b
<*> :: forall a b.
RecvHandshake13M m (a -> b)
-> RecvHandshake13M m a -> RecvHandshake13M m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RecvHandshake13M m a
-> RecvHandshake13M m b
-> RecvHandshake13M m c
liftA2 :: forall a b c.
(a -> b -> c)
-> RecvHandshake13M m a
-> RecvHandshake13M m b
-> RecvHandshake13M m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
*> :: forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m a
<* :: forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m a
Applicative, Applicative (RecvHandshake13M m)
Applicative (RecvHandshake13M m) =>
(forall a b.
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b)
-> (forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b)
-> (forall a. a -> RecvHandshake13M m a)
-> Monad (RecvHandshake13M m)
forall a. a -> RecvHandshake13M m a
forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
forall a b.
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b
forall (m :: * -> *). Monad m => Applicative (RecvHandshake13M m)
forall (m :: * -> *) a. Monad m => a -> RecvHandshake13M m a
forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b
>>= :: forall a b.
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
>> :: forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> RecvHandshake13M m a
return :: forall a. a -> RecvHandshake13M m a
Monad, Monad (RecvHandshake13M m)
Monad (RecvHandshake13M m) =>
(forall a. IO a -> RecvHandshake13M m a)
-> MonadIO (RecvHandshake13M m)
forall a. IO a -> RecvHandshake13M m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (RecvHandshake13M m)
forall (m :: * -> *) a. MonadIO m => IO a -> RecvHandshake13M m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> RecvHandshake13M m a
liftIO :: forall a. IO a -> RecvHandshake13M m a
MonadIO)
recvHandshake13
:: MonadIO m
=> Context
-> (Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13 :: forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx Handshake13 -> RecvHandshake13M m a
f = Context -> RecvHandshake13M m Handshake13
forall (m :: * -> *).
MonadIO m =>
Context -> RecvHandshake13M m Handshake13
getHandshake13 Context
ctx RecvHandshake13M m Handshake13
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
forall a b.
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handshake13 -> RecvHandshake13M m a
f
recvHandshake13hash
:: MonadIO m
=> Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash :: forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx ByteString -> Handshake13 -> RecvHandshake13M m a
f = do
d <- Context -> RecvHandshake13M m ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
getHandshake13 ctx >>= f d
getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13
getHandshake13 :: forall (m :: * -> *).
MonadIO m =>
Context -> RecvHandshake13M m Handshake13
getHandshake13 Context
ctx = StateT [Handshake13] m Handshake13
-> RecvHandshake13M m Handshake13
forall (m :: * -> *) a.
StateT [Handshake13] m a -> RecvHandshake13M m a
RecvHandshake13M (StateT [Handshake13] m Handshake13
-> RecvHandshake13M m Handshake13)
-> StateT [Handshake13] m Handshake13
-> RecvHandshake13M m Handshake13
forall a b. (a -> b) -> a -> b
$ do
currentState <- StateT [Handshake13] m [Handshake13]
forall s (m :: * -> *). MonadState s m => m s
get
case currentState of
(Handshake13
h : [Handshake13]
hs) -> Handshake13 -> [Handshake13] -> StateT [Handshake13] m Handshake13
forall {m :: * -> *} {s}.
(MonadIO m, MonadState s m) =>
Handshake13 -> s -> m Handshake13
found Handshake13
h [Handshake13]
hs
[] -> StateT [Handshake13] m Handshake13
recvLoop
where
found :: Handshake13 -> s -> m Handshake13
found Handshake13
h s
hs = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
hs m () -> m Handshake13 -> m Handshake13
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handshake13 -> m Handshake13
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Handshake13
h
recvLoop :: StateT [Handshake13] m Handshake13
recvLoop = do
epkt <- IO (Either TLSError Packet13)
-> StateT [Handshake13] m (Either TLSError Packet13)
forall a. IO a -> StateT [Handshake13] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx)
case epkt of
Right (Handshake13 []) -> String -> StateT [Handshake13] m Handshake13
forall a. HasCallStack => String -> a
error String
"invalid recvPacket13 result"
Right (Handshake13 (Handshake13
h : [Handshake13]
hs)) -> Handshake13 -> [Handshake13] -> StateT [Handshake13] m Handshake13
forall {m :: * -> *} {s}.
(MonadIO m, MonadState s m) =>
Handshake13 -> s -> m Handshake13
found Handshake13
h [Handshake13]
hs
Right Packet13
ChangeCipherSpec13 -> do
alreadyReceived <- IO Bool -> StateT [Handshake13] m Bool
forall a. IO a -> StateT [Handshake13] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT [Handshake13] m Bool)
-> IO Bool -> StateT [Handshake13] m Bool
forall a b. (a -> b) -> a -> b
$ Context -> HandshakeM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getCCS13Recv
if alreadyReceived
then
liftIO $ throwCore $ Error_Protocol "multiple CSS in TLS 1.3" UnexpectedMessage
else do
liftIO $ usingHState ctx $ setCCS13Recv True
recvLoop
Right (Alert13 [(AlertLevel, AlertDescription)]
_) -> TLSError -> StateT [Handshake13] m Handshake13
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
Error_TCP_Terminate
Right Packet13
x -> String -> Maybe String -> StateT [Handshake13] m Handshake13
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Packet13 -> String
forall a. Show a => a -> String
show Packet13
x) (String -> Maybe String
forall a. a -> Maybe a
Just String
"handshake 13")
Left TLSError
err -> TLSError -> StateT [Handshake13] m Handshake13
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
err
runRecvHandshake13 :: MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 :: forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 (RecvHandshake13M StateT [Handshake13] m a
f) = do
(result, new) <- StateT [Handshake13] m a -> [Handshake13] -> m (a, [Handshake13])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT [Handshake13] m a
f []
unless (null new) $ unexpected "spurious handshake 13" Nothing
return result
checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO ()
checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO ()
checkHashSignatureValid13 HashAndSignatureAlgorithm
hs =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 HashAndSignatureAlgorithm
hs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
let msg :: String
msg = String
"invalid TLS13 hash and signature algorithm: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HashAndSignatureAlgorithm -> String
forall a. Show a => a -> String
show HashAndSignatureAlgorithm
hs
in 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
msg AlertDescription
IllegalParameter
isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 HashAndSignatureAlgorithm
hs = HashAndSignatureAlgorithm
hs HashAndSignatureAlgorithm -> [HashAndSignatureAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HashAndSignatureAlgorithm]
signatureSchemesForTLS13
calculateEarlySecret
:: Context
-> CipherChoice
-> Either ByteString (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret :: Context
-> CipherChoice
-> Either ByteString (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret Context
ctx CipherChoice
choice Either ByteString (BaseSecret EarlySecret)
maux Bool
initialized = do
hCh <-
if Bool
initialized
then Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
else do
hmsgs <- Context -> HandshakeM [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM [ByteString]
getHandshakeMessages
return $ hash usedHash $ B.concat hmsgs
let earlySecret = case Either ByteString (BaseSecret EarlySecret)
maux of
Right (BaseSecret ByteString
sec) -> ByteString
sec
Left ByteString
psk -> Hash -> ByteString -> ByteString -> ByteString
hkdfExtract Hash
usedHash ByteString
zero ByteString
psk
clientEarlySecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
earlySecret ByteString
"c e traffic" ByteString
hCh
cets = ByteString -> ClientTrafficSecret EarlySecret
forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
clientEarlySecret :: ClientTrafficSecret EarlySecret
logKey ctx cets
return $ SecretPair (BaseSecret earlySecret) cets
where
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
zero :: ByteString
zero = CipherChoice -> ByteString
cZero CipherChoice
choice
initEarlySecret :: CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret :: CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice Maybe ByteString
mpsk = ByteString -> BaseSecret EarlySecret
forall a. ByteString -> BaseSecret a
BaseSecret ByteString
sec
where
sec :: ByteString
sec = Hash -> ByteString -> ByteString -> ByteString
hkdfExtract Hash
usedHash ByteString
zero ByteString
zeroOrPSK
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
zero :: ByteString
zero = CipherChoice -> ByteString
cZero CipherChoice
choice
zeroOrPSK :: ByteString
zeroOrPSK = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
zero Maybe ByteString
mpsk
calculateHandshakeSecret
:: Context
-> CipherChoice
-> BaseSecret EarlySecret
-> ByteString
-> IO (SecretTriple HandshakeSecret)
calculateHandshakeSecret :: Context
-> CipherChoice
-> BaseSecret EarlySecret
-> ByteString
-> IO (SecretTriple HandshakeSecret)
calculateHandshakeSecret Context
ctx CipherChoice
choice (BaseSecret ByteString
sec) ByteString
ecdhe = do
hChSh <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
let handshakeSecret =
Hash -> ByteString -> ByteString -> ByteString
hkdfExtract
Hash
usedHash
(Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
sec ByteString
"derived" (Hash -> ByteString -> ByteString
hash Hash
usedHash ByteString
""))
ByteString
ecdhe
let clientHandshakeSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
handshakeSecret ByteString
"c hs traffic" ByteString
hChSh
serverHandshakeSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
handshakeSecret ByteString
"s hs traffic" ByteString
hChSh
let shts =
ByteString -> ServerTrafficSecret HandshakeSecret
forall a. ByteString -> ServerTrafficSecret a
ServerTrafficSecret ByteString
serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
chts =
ByteString -> ClientTrafficSecret HandshakeSecret
forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
logKey ctx shts
logKey ctx chts
return $ SecretTriple (BaseSecret handshakeSecret) chts shts
where
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
calculateApplicationSecret
:: Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> ByteString
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret :: Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> ByteString
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret Context
ctx CipherChoice
choice (BaseSecret ByteString
sec) ByteString
hChSf = do
let applicationSecret :: ByteString
applicationSecret =
Hash -> ByteString -> ByteString -> ByteString
hkdfExtract
Hash
usedHash
(Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
sec ByteString
"derived" (Hash -> ByteString -> ByteString
hash Hash
usedHash ByteString
""))
ByteString
zero
let clientApplicationSecret0 :: ByteString
clientApplicationSecret0 = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
applicationSecret ByteString
"c ap traffic" ByteString
hChSf
serverApplicationSecret0 :: ByteString
serverApplicationSecret0 = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
applicationSecret ByteString
"s ap traffic" ByteString
hChSf
exporterSecret :: ByteString
exporterSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
applicationSecret ByteString
"exp master" ByteString
hChSf
Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> TLSSt ()
setTLS13ExporterSecret ByteString
exporterSecret
let sts0 :: ServerTrafficSecret ApplicationSecret
sts0 =
ByteString -> ServerTrafficSecret ApplicationSecret
forall a. ByteString -> ServerTrafficSecret a
ServerTrafficSecret ByteString
serverApplicationSecret0
:: ServerTrafficSecret ApplicationSecret
let cts0 :: ClientTrafficSecret ApplicationSecret
cts0 =
ByteString -> ClientTrafficSecret ApplicationSecret
forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
clientApplicationSecret0
:: ClientTrafficSecret ApplicationSecret
Context -> ServerTrafficSecret ApplicationSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx ServerTrafficSecret ApplicationSecret
sts0
Context -> ClientTrafficSecret ApplicationSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx ClientTrafficSecret ApplicationSecret
cts0
SecretTriple ApplicationSecret
-> IO (SecretTriple ApplicationSecret)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SecretTriple ApplicationSecret
-> IO (SecretTriple ApplicationSecret))
-> SecretTriple ApplicationSecret
-> IO (SecretTriple ApplicationSecret)
forall a b. (a -> b) -> a -> b
$ BaseSecret ApplicationSecret
-> ClientTrafficSecret ApplicationSecret
-> ServerTrafficSecret ApplicationSecret
-> SecretTriple ApplicationSecret
forall a.
BaseSecret a
-> ClientTrafficSecret a -> ServerTrafficSecret a -> SecretTriple a
SecretTriple (ByteString -> BaseSecret ApplicationSecret
forall a. ByteString -> BaseSecret a
BaseSecret ByteString
applicationSecret) ClientTrafficSecret ApplicationSecret
cts0 ServerTrafficSecret ApplicationSecret
sts0
where
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
zero :: ByteString
zero = CipherChoice -> ByteString
cZero CipherChoice
choice
calculateResumptionSecret
:: Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret :: Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret Context
ctx CipherChoice
choice (BaseSecret ByteString
sec) = do
hChCf <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
let resumptionSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
sec ByteString
"res master" ByteString
hChCf
return $ BaseSecret resumptionSecret
where
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
derivePSK
:: CipherChoice -> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK :: CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice (BaseSecret ByteString
sec) ByteString
nonce =
Hash -> ByteString -> ByteString -> ByteString -> Int -> ByteString
hkdfExpandLabel Hash
usedHash ByteString
sec ByteString
"resumption" ByteString
nonce Int
hashSize
where
usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
hashSize :: Int
hashSize = Hash -> Int
hashDigestSize Hash
usedHash
checkKeyShareKeyLength :: KeyShareEntry -> Bool
checkKeyShareKeyLength :: KeyShareEntry -> Bool
checkKeyShareKeyLength KeyShareEntry
ks = Group -> Int
keyShareKeyLength Group
grp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
B.length ByteString
key
where
grp :: Group
grp = KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
ks
key :: ByteString
key = KeyShareEntry -> ByteString
keyShareEntryKeyExchange KeyShareEntry
ks
keyShareKeyLength :: Group -> Int
keyShareKeyLength :: Group -> Int
keyShareKeyLength Group
P256 = Int
65
keyShareKeyLength Group
P384 = Int
97
keyShareKeyLength Group
P521 = Int
133
keyShareKeyLength Group
X25519 = Int
32
keyShareKeyLength Group
X448 = Int
56
keyShareKeyLength Group
FFDHE2048 = Int
256
keyShareKeyLength Group
FFDHE3072 = Int
384
keyShareKeyLength Group
FFDHE4096 = Int
512
keyShareKeyLength Group
FFDHE6144 = Int
768
keyShareKeyLength Group
FFDHE8192 = Int
1024
keyShareKeyLength Group
_ = String -> Int
forall a. HasCallStack => String -> a
error String
"keyShareKeyLength"
setRTT :: Context -> Millisecond -> IO ()
setRTT :: Context -> Millisecond -> IO ()
setRTT Context
ctx Millisecond
chSentTime = do
shRecvTime <- IO Millisecond
getCurrentTimeFromBase
let rtt' = Millisecond
shRecvTime Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
chSentTime
rtt = if Millisecond
rtt' Millisecond -> Millisecond -> Bool
forall a. Eq a => a -> a -> Bool
== Millisecond
0 then Millisecond
10 else Millisecond
rtt'
modifyTLS13State ctx $ \TLS13State
st -> TLS13State
st{tls13stRTT = rtt}