{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns #-}

-- |
-- Module      : Network.TLS.Handshake.Common13
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Handshake.Common13
       ( makeFinished
       , checkFinished
       , makeServerKeyShare
       , makeClientKeyShare
       , fromServerKeyShare
       , makeCertVerify
       , checkCertVerify
       , makePSKBinder
       , replacePSKBinder
       , sendChangeCipherSpec13
       , handshakeTerminate13
       , makeCertRequest
       , createTLS13TicketInfo
       , ageToObfuscatedAge
       , isAgeValid
       , getAge
       , checkFreshness
       , getCurrentTimeFromBase
       , getSessionData13
       , ensureNullCompression
       , isHashSignatureValid13
       , safeNonNegative32
       , RecvHandshake13M
       , runRecvHandshake13
       , recvHandshake13
       , recvHandshake13hash
       , CipherChoice(..)
       , makeCipherChoice
       , initEarlySecret
       , calculateEarlySecret
       , calculateHandshakeSecret
       , calculateApplicationSecret
       , calculateResumptionSecret
       , derivePSK
       , checkKeyShareKeyLength
       ) 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.Compression
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
import Data.IORef (writeIORef)

----------------------------------------------------------------

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
    ByteString
finished <- Hash -> ByteString -> ByteString -> ByteString
makeVerifyData Hash
usedHash ByteString
baseKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe ByteString)
ctxFinished Context
ctx) (forall a. a -> Maybe a
Just ByteString
finished)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Handshake13
Finished13 ByteString
finished

checkFinished :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
checkFinished :: forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
checkFinished Context
ctx Hash
usedHash ByteString
baseKey ByteString
hashValue ByteString
verifyData = do
    let verifyData' :: ByteString
verifyData' = Hash -> ByteString -> ByteString -> ByteString
makeVerifyData Hash
usedHash ByteString
baseKey ByteString
hashValue
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
verifyData forall a. Eq a => a -> a -> Bool
/= ByteString -> Int
B.length ByteString
verifyData') forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"broken Finished", Bool
True, AlertDescription
DecodeError)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
verifyData' forall a. Eq a => a -> a -> Bool
== ByteString
verifyData) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"cannot verify finished"
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe ByteString)
ctxPeerFinished Context
ctx) (forall a. a -> Maybe a
Just ByteString
verifyData)

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    -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (forall a. Show a => a -> String
show CryptoError
e, Bool
True, AlertDescription
IllegalParameter)
  Right GroupPublic
cpub -> do
      Maybe (GroupPublic, GroupKey)
ecdhePair <- Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))
generateECDHEShared Context
ctx GroupPublic
cpub
      case Maybe (GroupPublic, GroupKey)
ecdhePair of
          Maybe (GroupPublic, GroupKey)
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
msgInvalidPublic, Bool
True, 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 forall (m :: * -> *) a. Monad m => a -> m a
return (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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Group
grp 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
    (GroupPrivate
cpri, GroupPublic
cpub) <- Context -> Group -> IO (GroupPrivate, GroupPublic)
generateECDHE Context
ctx Group
grp
    let wcpub :: ByteString
wcpub = GroupPublic -> ByteString
IES.encodeGroupPublic GroupPublic
cpub
        clientKeyShare :: KeyShareEntry
clientKeyShare = Group -> ByteString -> KeyShareEntry
KeyShareEntry Group
grp ByteString
wcpub
    forall (m :: * -> *) a. Monad m => a -> m a
return (GroupPrivate
cpri, KeyShareEntry
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    -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (forall a. Show a => a -> String
show CryptoError
e, Bool
True, AlertDescription
IllegalParameter)
  Right GroupPublic
spub -> case GroupPublic -> GroupPrivate -> Maybe GroupKey
IES.groupGetShared GroupPublic
spub GroupPrivate
cpri of
    Just GroupKey
shared -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert GroupKey
shared
    Maybe GroupKey
Nothing     -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"cannot generate a shared secret on (EC)DH", Bool
True, 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
cc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
isClientContext
    let ctxStr :: ByteString
ctxStr | Role
cc forall a. Eq a => a -> a -> Bool
== Role
ClientRole = ByteString
clientContextString
               | Bool
otherwise        = ByteString
serverContextString
        target :: ByteString
target = ByteString -> ByteString -> ByteString
makeTarget ByteString
ctxStr ByteString
hashValue
    HashAndSignatureAlgorithm -> ByteString -> Handshake13
CertVerify13 HashAndSignatureAlgorithm
hs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m ByteString
sign Context
ctx PubKey
pub HashAndSignatureAlgorithm
hs ByteString
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Role
cc <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
isClientContext
        let ctxStr :: ByteString
ctxStr | Role
cc forall a. Eq a => a -> a -> Bool
== Role
ClientRole = ByteString
serverContextString -- opposite context
                | Bool
otherwise        = ByteString
clientContextString
            target :: ByteString
target = ByteString -> ByteString -> ByteString
makeTarget ByteString
ctxStr ByteString
hashValue
            sigParams :: SignatureParams
sigParams = PubKey -> Maybe HashAndSignatureAlgorithm -> SignatureParams
signatureParams PubKey
pub (forall a. a -> Maybe a
Just HashAndSignatureAlgorithm
hs)
        HashAndSignatureAlgorithm -> IO ()
checkHashSignatureValid13 HashAndSignatureAlgorithm
hs
        Context -> Maybe HashAndSignatureAlgorithm -> IO ()
checkSupportedHashSignature Context
ctx (forall a. a -> Maybe a
Just HashAndSignatureAlgorithm
hs)
        Context -> SignatureParams -> ByteString -> ByteString -> IO Bool
verifyPublic Context
ctx SignatureParams
sigParams ByteString
target ByteString
signature
    | Bool
otherwise = 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 forall a b. (a -> b) -> a -> b
$ do
    ByteString -> Put
putBytes 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Role
cc <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
isClientContext
    let sigParams :: SignatureParams
sigParams = PubKey -> Maybe HashAndSignatureAlgorithm -> SignatureParams
signatureParams PubKey
pub (forall a. a -> Maybe a
Just HashAndSignatureAlgorithm
hs)
    Context -> Role -> SignatureParams -> ByteString -> IO ByteString
signPrivate Context
ctx Role
cc SignatureParams
sigParams ByteString
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
    [ByteString]
rmsgs0 <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM [ByteString]
getHandshakeMessagesRev -- fixme
    let rmsgs :: [ByteString]
rmsgs = case Maybe ByteString
mch of
          Just ByteString
ch -> ByteString -> ByteString
trunc ByteString
ch forall a. a -> [a] -> [a]
: [ByteString]
rmsgs0
          Maybe ByteString
Nothing -> ByteString -> ByteString
trunc (forall a. [a] -> a
head [ByteString]
rmsgs0) forall a. a -> [a] -> [a]
: forall a. [a] -> [a]
tail [ByteString]
rmsgs0
        hChTruncated :: ByteString
hChTruncated = Hash -> ByteString -> ByteString
hash Hash
usedHash forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ByteString]
rmsgs
        binderKey :: ByteString
binderKey = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
sec ByteString
"res binder" (Hash -> ByteString -> ByteString
hash Hash
usedHash ByteString
"")
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Hash -> ByteString -> ByteString -> ByteString
makeVerifyData Hash
usedHash ByteString
binderKey ByteString
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 forall a. Num a => a -> a -> a
- Int
truncLen

replacePSKBinder :: ByteString -> ByteString -> ByteString
replacePSKBinder :: ByteString -> ByteString -> ByteString
replacePSKBinder ByteString
pskz ByteString
binder = ByteString
identities ByteString -> ByteString -> ByteString
`B.append` ByteString
binders
  where
    bindersSize :: Int
bindersSize = ByteString -> Int
B.length ByteString
binder forall a. Num a => a -> a -> a
+ Int
3
    identities :: ByteString
identities  = Int -> ByteString -> ByteString
B.take (ByteString -> Int
B.length ByteString
pskz forall a. Num a => a -> a -> a
- Int
bindersSize) ByteString
pskz
    binders :: ByteString
binders     = Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ ByteString -> Put
putOpaque16 forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ ByteString -> Put
putOpaque8 ByteString
binder

----------------------------------------------------------------

sendChangeCipherSpec13 :: Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 :: forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx = do
    Bool
sent <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ do
                Bool
b <- HandshakeM Bool
getCCS13Sent
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setCCS13Sent Bool
True
                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sent forall a b. (a -> b) -> a -> b
$ forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx Packet13
ChangeCipherSpec13

----------------------------------------------------------------

-- | TLS13 handshake wrap up & clean up.  Contrary to @handshakeTerminate@, this
-- does not handle session, which is managed separately for TLS 1.3.  This does
-- not reset byte counters because renegotiation is not allowed.  And a few more
-- state attributes are preserved, necessary for TLS13 handshake modes, session
-- tickets and post-handshake authentication.
handshakeTerminate13 :: Context -> IO ()
handshakeTerminate13 :: Context -> IO ()
handshakeTerminate13 Context
ctx = do
    -- forget most handshake data
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Context -> MVar (Maybe HandshakeState)
ctxHandshake Context
ctx) forall a b. (a -> b) -> a -> b
$ \ Maybe HandshakeState
mhshake ->
        case Maybe HandshakeState
mhshake of
            Maybe HandshakeState
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just HandshakeState
hshake ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Version -> ClientRandom -> HandshakeState
newEmptyHandshake (HandshakeState -> Version
hstClientVersion HandshakeState
hshake) (HandshakeState -> ClientRandom
hstClientRandom HandshakeState
hshake))
                    { hstServerRandom :: Maybe ServerRandom
hstServerRandom = HandshakeState -> Maybe ServerRandom
hstServerRandom HandshakeState
hshake
                    , hstMasterSecret :: Maybe ByteString
hstMasterSecret = HandshakeState -> Maybe ByteString
hstMasterSecret HandshakeState
hshake
                    , hstNegotiatedGroup :: Maybe Group
hstNegotiatedGroup = HandshakeState -> Maybe Group
hstNegotiatedGroup HandshakeState
hshake
                    , hstHandshakeDigest :: HandshakeDigest
hstHandshakeDigest = HandshakeState -> HandshakeDigest
hstHandshakeDigest HandshakeState
hshake
                    , hstTLS13HandshakeMode :: HandshakeMode13
hstTLS13HandshakeMode = HandshakeState -> HandshakeMode13
hstTLS13HandshakeMode HandshakeState
hshake
                    , hstTLS13RTT0Status :: RTT0Status
hstTLS13RTT0Status = HandshakeState -> RTT0Status
hstTLS13RTT0Status HandshakeState
hshake
                    , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret)
hstTLS13ResumptionSecret = HandshakeState -> Maybe (BaseSecret ResumptionSecret)
hstTLS13ResumptionSecret HandshakeState
hshake
                    }
    -- forget handshake data stored in TLS state
    forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
        Maybe KeyShare -> TLSSt ()
setTLS13KeyShare forall a. Maybe a
Nothing
        Maybe PreSharedKey -> TLSSt ()
setTLS13PreSharedKey forall a. Maybe a
Nothing
    -- mark the secure connection up and running.
    Context -> Established -> IO ()
setEstablished Context
ctx Established
Established

----------------------------------------------------------------

makeCertRequest :: ServerParams -> Context -> CertReqContext -> Handshake13
makeCertRequest :: ServerParams -> Context -> ByteString -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx =
    let sigAlgs :: ByteString
sigAlgs = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ [HashAndSignatureAlgorithm] -> SignatureAlgorithms
SignatureAlgorithms forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        caDns :: [DistinguishedName]
caDns = forall a b. (a -> b) -> [a] -> [b]
map SignedCertificate -> DistinguishedName
extractCAname forall a b. (a -> b) -> a -> b
$ ServerParams -> [SignedCertificate]
serverCACertificates ServerParams
sparams
        caDnsEncoded :: ByteString
caDnsEncoded = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ [DistinguishedName] -> CertificateAuthorities
CertificateAuthorities [DistinguishedName]
caDns
        caExtension :: [ExtensionRaw]
caExtension
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DistinguishedName]
caDns = []
            | Bool
otherwise  = [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_CertificateAuthorities ByteString
caDnsEncoded]
        crexts :: [ExtensionRaw]
crexts = ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_SignatureAlgorithms ByteString
sigAlgs forall a. a -> [a] -> [a]
: [ExtensionRaw]
caExtension
     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
    -- Left:  serverSendTime
    -- Right: clientReceiveTime
    Millisecond
bTime <- IO Millisecond
getCurrentTimeFromBase
    Second
add <- case Either Context Second
ecw of
        Left Context
ctx -> forall a. (a -> CompressionID -> a) -> a -> ByteString -> a
B.foldl' forall {a} {a}. (Integral a, Num a) => a -> a -> a
(*+) Second
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO ByteString
getStateRNG Context
ctx Int
4
        Right Second
ad -> forall (m :: * -> *) a. Monad m => a -> m a
return Second
ad
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Second
-> Second -> Millisecond -> Maybe Millisecond -> TLS13TicketInfo
TLS13TicketInfo Second
life Second
add Millisecond
bTime Maybe Millisecond
mrtt
  where
    a
x *+ :: a -> a -> a
*+ a
y = a
x forall a. Num a => a -> a -> a
* a
256 forall a. Num 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
tinfo = Second
obfage
  where
    !obfage :: Second
obfage = Second
age forall a. Num a => a -> a -> a
+ TLS13TicketInfo -> Second
ageAdd TLS13TicketInfo
tinfo

obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second
obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second
obfuscatedAgeToAge Second
obfage TLS13TicketInfo
tinfo = Second
age
  where
    !age :: Second
age = Second
obfage forall a. Num a => a -> a -> a
- TLS13TicketInfo -> Second
ageAdd TLS13TicketInfo
tinfo

isAgeValid :: Second -> TLS13TicketInfo -> Bool
isAgeValid :: Second -> TLS13TicketInfo -> Bool
isAgeValid Second
age TLS13TicketInfo
tinfo = Second
age forall a. Ord a => a -> a -> Bool
<= TLS13TicketInfo -> Second
lifetime TLS13TicketInfo
tinfo forall a. Num a => a -> a -> a
* Second
1000

getAge :: TLS13TicketInfo -> IO Second
getAge :: TLS13TicketInfo -> IO Second
getAge TLS13TicketInfo
tinfo = do
    let clientReceiveTime :: Millisecond
clientReceiveTime = TLS13TicketInfo -> Millisecond
txrxTime TLS13TicketInfo
tinfo
    Millisecond
clientSendTime <- IO Millisecond
getCurrentTimeFromBase
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. (Integral a, Num b) => a -> b
fromIntegral (Millisecond
clientSendTime forall a. Num a => a -> a -> a
- Millisecond
clientReceiveTime) -- milliseconds

checkFreshness :: TLS13TicketInfo -> Second -> IO Bool
checkFreshness :: TLS13TicketInfo -> Second -> IO Bool
checkFreshness TLS13TicketInfo
tinfo Second
obfAge = do
    Millisecond
serverReceiveTime <- IO Millisecond
getCurrentTimeFromBase
    let freshness :: Millisecond
freshness = if Millisecond
expectedArrivalTime forall a. Ord a => a -> a -> Bool
> Millisecond
serverReceiveTime
                    then Millisecond
expectedArrivalTime forall a. Num a => a -> a -> a
- Millisecond
serverReceiveTime
                    else Millisecond
serverReceiveTime forall a. Num a => a -> a -> a
- Millisecond
expectedArrivalTime
    -- Some implementations round age up to second.
    -- We take max of 2000 and rtt in the case where rtt is too small.
    let tolerance :: Millisecond
tolerance = forall a. Ord a => a -> a -> a
max Millisecond
2000 Millisecond
rtt
        isFresh :: Bool
isFresh = Millisecond
freshness forall a. Ord a => a -> a -> Bool
< Millisecond
tolerance
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
isAlive Bool -> Bool -> Bool
&& Bool
isFresh
  where
    serverSendTime :: Millisecond
serverSendTime = TLS13TicketInfo -> Millisecond
txrxTime TLS13TicketInfo
tinfo
    Just Millisecond
rtt = TLS13TicketInfo -> Maybe Millisecond
estimatedRTT TLS13TicketInfo
tinfo
    age :: Second
age = Second -> TLS13TicketInfo -> Second
obfuscatedAgeToAge Second
obfAge TLS13TicketInfo
tinfo
    expectedArrivalTime :: Millisecond
expectedArrivalTime = Millisecond
serverSendTime forall a. Num a => a -> a -> a
+ Millisecond
rtt forall a. Num a => a -> a -> a
+ 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 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) =
    forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int64
s forall a. Num a => a -> a -> a
- Int64
base) forall a. Num a => a -> a -> a
* Int64
1000) forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
us forall a. Integral a => a -> a -> a
`div` Int32
1000)
  where
    base :: Int64
base = Int64
1483228800
    -- UnixTime (CTime base) _= parseUnixTimeGMT webDateFormat "Sun, 01 Jan 2017 00:00:00 GMT"

----------------------------------------------------------------

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
    Version
ver   <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Maybe ByteString
malpn <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe ByteString)
getNegotiatedProtocol
    Maybe String
sni   <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe String)
getClientSNI
    Maybe Group
mgrp  <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe Group)
getNegotiatedGroup
    forall (m :: * -> *) a. Monad m => a -> m a
return SessionData {
        sessionVersion :: Version
sessionVersion     = Version
ver
      , sessionCipher :: ExtensionID
sessionCipher      = Cipher -> ExtensionID
cipherID Cipher
usedCipher
      , sessionCompression :: CompressionID
sessionCompression = CompressionID
0
      , sessionClientSNI :: Maybe String
sessionClientSNI   = Maybe String
sni
      , sessionSecret :: ByteString
sessionSecret      = ByteString
psk
      , sessionGroup :: Maybe Group
sessionGroup       = Maybe Group
mgrp
      , sessionTicketInfo :: Maybe TLS13TicketInfo
sessionTicketInfo  = forall a. a -> Maybe a
Just TLS13TicketInfo
tinfo
      , sessionALPN :: Maybe ByteString
sessionALPN        = Maybe ByteString
malpn
      , sessionMaxEarlyDataSize :: Int
sessionMaxEarlyDataSize = Int
maxSize
      , sessionFlags :: [SessionFlag]
sessionFlags       = []
      }

----------------------------------------------------------------

ensureNullCompression :: MonadIO m => CompressionID -> m ()
ensureNullCompression :: forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression CompressionID
compression =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompressionID
compression forall a. Eq a => a -> a -> Bool
/= Compression -> CompressionID
compressionID Compression
nullCompression) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"compression is not allowed in TLS 1.3", Bool
True, AlertDescription
IllegalParameter)

-- Word32 is used in TLS 1.3 protocol.
-- Int is used for API for Haskell TLS because it is natural.
-- If Int is 64 bits, users can specify bigger number than Word32.
-- If Int is 32 bits, 2^31 or larger may be converted into minus numbers.
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 forall a. Ord a => a -> a -> Bool
<= a
0                = a
0
  | forall b. FiniteBits b => b -> Int
finiteBitSize a
x forall a. Ord a => a -> a -> Bool
<= Int
32 = a
x
  | Bool
otherwise             = a
x forall a. Ord a => a -> a -> a
`min` forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word32)
----------------------------------------------------------------

newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)
    deriving (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
<$ :: forall a b. a -> RecvHandshake13M m b -> RecvHandshake13M m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RecvHandshake13M m b -> RecvHandshake13M m a
fmap :: forall a b.
(a -> b) -> RecvHandshake13M m a -> RecvHandshake13M m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RecvHandshake13M m a -> RecvHandshake13M m b
Functor, 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
<* :: forall a b.
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m a
$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 b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> RecvHandshake13M m b -> RecvHandshake13M m b
liftA2 :: forall a b c.
(a -> b -> c)
-> RecvHandshake13M m a
-> RecvHandshake13M m b
-> RecvHandshake13M m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RecvHandshake13M m a
-> RecvHandshake13M m b
-> RecvHandshake13M m c
<*> :: forall a b.
RecvHandshake13M m (a -> b)
-> RecvHandshake13M m a -> RecvHandshake13M m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m (a -> b)
-> RecvHandshake13M m a -> RecvHandshake13M m b
pure :: forall a. a -> RecvHandshake13M m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> RecvHandshake13M m a
Applicative, 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
return :: forall a. a -> RecvHandshake13M m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> RecvHandshake13M m a
>> :: 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 b
>>= :: forall a b.
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RecvHandshake13M m a
-> (a -> RecvHandshake13M m b) -> RecvHandshake13M m b
Monad, 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
liftIO :: forall a. IO a -> RecvHandshake13M m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => 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 = forall (m :: * -> *).
MonadIO m =>
Context -> RecvHandshake13M m Handshake13
getHandshake13 Context
ctx 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
    ByteString
d <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
    forall (m :: * -> *).
MonadIO m =>
Context -> RecvHandshake13M m Handshake13
getHandshake13 Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Handshake13 -> RecvHandshake13M m a
f ByteString
d

getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13
getHandshake13 :: forall (m :: * -> *).
MonadIO m =>
Context -> RecvHandshake13M m Handshake13
getHandshake13 Context
ctx = forall (m :: * -> *) a.
StateT [Handshake13] m a -> RecvHandshake13M m a
RecvHandshake13M forall a b. (a -> b) -> a -> b
$ do
    [Handshake13]
currentState <- forall s (m :: * -> *). MonadState s m => m s
get
    case [Handshake13]
currentState of
        (Handshake13
h:[Handshake13]
hs) -> 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *). MonadState s m => s -> m ()
put s
hs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Handshake13
h
    recvLoop :: StateT [Handshake13] m Handshake13
recvLoop = do
        Either TLSError Packet13
epkt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx)
        case Either TLSError Packet13
epkt of
            Right (Handshake13 [])     -> forall a. HasCallStack => String -> a
error String
"invalid recvPacket13 result"
            Right (Handshake13 (Handshake13
h:[Handshake13]
hs)) -> forall {m :: * -> *} {s}.
(MonadIO m, MonadState s m) =>
Handshake13 -> s -> m Handshake13
found Handshake13
h [Handshake13]
hs
            Right Packet13
ChangeCipherSpec13   -> StateT [Handshake13] m Handshake13
recvLoop
            Right Packet13
x                    -> forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Packet13
x) (forall a. a -> Maybe a
Just String
"handshake 13")
            Left TLSError
err                   -> 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
    (a
result, [Handshake13]
new) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT [Handshake13] m a
f []
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Handshake13]
new) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected String
"spurious handshake 13" forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return a
result

----------------------------------------------------------------

-- some hash/signature combinations have been deprecated in TLS13 and should
-- not be used
checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO ()
checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO ()
checkHashSignatureValid13 HashAndSignatureAlgorithm
hs =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 HashAndSignatureAlgorithm
hs) forall a b. (a -> b) -> a -> b
$
        let msg :: String
msg = String
"invalid TLS13 hash and signature algorithm: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HashAndSignatureAlgorithm
hs
         in forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
msg, Bool
True, AlertDescription
IllegalParameter)

isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 (HashAlgorithm
HashIntrinsic, SignatureAlgorithm
s) =
    SignatureAlgorithm
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ SignatureAlgorithm
SignatureRSApssRSAeSHA256
             , SignatureAlgorithm
SignatureRSApssRSAeSHA384
             , SignatureAlgorithm
SignatureRSApssRSAeSHA512
             , SignatureAlgorithm
SignatureEd25519
             , SignatureAlgorithm
SignatureEd448
             , SignatureAlgorithm
SignatureRSApsspssSHA256
             , SignatureAlgorithm
SignatureRSApsspssSHA384
             , SignatureAlgorithm
SignatureRSApsspssSHA512
             ]
isHashSignatureValid13 (HashAlgorithm
h, SignatureAlgorithm
SignatureECDSA) =
    HashAlgorithm
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ HashAlgorithm
HashSHA256, HashAlgorithm
HashSHA384, HashAlgorithm
HashSHA512 ]
isHashSignatureValid13 HashAndSignatureAlgorithm
_ = Bool
False

data CipherChoice = CipherChoice {
    CipherChoice -> Version
cVersion :: Version
  , CipherChoice -> Cipher
cCipher  :: Cipher
  , CipherChoice -> Hash
cHash    :: Hash
  , CipherChoice -> ByteString
cZero    :: !ByteString
  }

makeCipherChoice :: Version -> Cipher -> CipherChoice
makeCipherChoice :: Version -> Cipher -> CipherChoice
makeCipherChoice Version
ver Cipher
cipher = Version -> Cipher -> Hash -> ByteString -> CipherChoice
CipherChoice Version
ver Cipher
cipher Hash
h ByteString
zero
  where
    h :: Hash
h = Cipher -> Hash
cipherHash Cipher
cipher
    zero :: ByteString
zero = Int -> CompressionID -> ByteString
B.replicate (Hash -> Int
hashDigestSize Hash
h) CompressionID
0

----------------------------------------------------------------

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
    ByteString
hCh <- if Bool
initialized then
               forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
             else do
               [ByteString]
hmsgs <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM [ByteString]
getHandshakeMessages
               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Hash -> ByteString -> ByteString
hash Hash
usedHash forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString]
hmsgs
    let earlySecret :: ByteString
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 :: ByteString
clientEarlySecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
earlySecret ByteString
"c e traffic" ByteString
hCh
        cets :: ClientTrafficSecret EarlySecret
cets = forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
clientEarlySecret :: ClientTrafficSecret EarlySecret
    forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx ClientTrafficSecret EarlySecret
cets
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. BaseSecret a -> ClientTrafficSecret a -> SecretPair a
SecretPair (forall a. ByteString -> BaseSecret a
BaseSecret ByteString
earlySecret) ClientTrafficSecret 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 = 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 = case Maybe ByteString
mpsk of
      Just ByteString
psk -> ByteString
psk
      Maybe ByteString
Nothing  -> ByteString
zero

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
        ByteString
hChSh <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
        let handshakeSecret :: ByteString
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 :: ByteString
clientHandshakeSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
handshakeSecret ByteString
"c hs traffic" ByteString
hChSh
            serverHandshakeSecret :: ByteString
serverHandshakeSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
handshakeSecret ByteString
"s hs traffic" ByteString
hChSh
        let shts :: ServerTrafficSecret HandshakeSecret
shts = forall a. ByteString -> ServerTrafficSecret a
ServerTrafficSecret ByteString
serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
            chts :: ClientTrafficSecret HandshakeSecret
chts = forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
        forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx ServerTrafficSecret HandshakeSecret
shts
        forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx ClientTrafficSecret HandshakeSecret
chts
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
BaseSecret a
-> ClientTrafficSecret a -> ServerTrafficSecret a -> SecretTriple a
SecretTriple (forall a. ByteString -> BaseSecret a
BaseSecret ByteString
handshakeSecret) ClientTrafficSecret HandshakeSecret
chts ServerTrafficSecret HandshakeSecret
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
        exporterMasterSecret :: ByteString
exporterMasterSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
applicationSecret ByteString
"exp master" ByteString
hChSf
    forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ ByteString -> TLSSt ()
setExporterMasterSecret ByteString
exporterMasterSecret
    let sts0 :: ServerTrafficSecret ApplicationSecret
sts0 = forall a. ByteString -> ServerTrafficSecret a
ServerTrafficSecret ByteString
serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret
    let cts0 :: ClientTrafficSecret ApplicationSecret
cts0 = forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
    forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx ServerTrafficSecret ApplicationSecret
sts0
    forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx ClientTrafficSecret ApplicationSecret
cts0
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
BaseSecret a
-> ClientTrafficSecret a -> ServerTrafficSecret a -> SecretTriple a
SecretTriple (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
    ByteString
hChCf <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
    let resumptionMasterSecret :: ByteString
resumptionMasterSecret = Hash -> ByteString -> ByteString -> ByteString -> ByteString
deriveSecret Hash
usedHash ByteString
sec ByteString
"res master" ByteString
hChCf
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ByteString -> BaseSecret a
BaseSecret ByteString
resumptionMasterSecret
  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 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 -- 32 * 2 + 1
keyShareKeyLength Group
P384      =   Int
97 -- 48 * 2 + 1
keyShareKeyLength Group
P521      =  Int
133 -- 66 * 2 + 1
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