{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Network.TLS.Handshake.Client.Common (
throwMiscErrorOnException,
doServerKeyExchange,
doCertificate,
getLocalHashSigAlg,
clientChain,
sigAlgsToCertTypes,
setALPN,
contextSync,
clientSessions,
) where
import Control.Exception (SomeException)
import Control.Monad.State.Strict
import Data.X509 (ExtKeyUsageFlag (..))
import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Credentials
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Certificate
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Control
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Imports
import Network.TLS.Packet hiding (getExtensions)
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Util (catchException)
import Network.TLS.X509
throwMiscErrorOnException :: String -> SomeException -> IO a
throwMiscErrorOnException :: forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
msg SomeException
e =
TLSError -> IO a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO a) -> TLSError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Misc (String -> TLSError) -> String -> TLSError
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
doServerKeyExchange :: Context -> ServerKeyXchgAlgorithmData -> IO ()
doServerKeyExchange :: Context -> ServerKeyXchgAlgorithmData -> IO ()
doServerKeyExchange Context
ctx ServerKeyXchgAlgorithmData
origSkx = do
cipher <- Context -> HandshakeM Cipher -> IO Cipher
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
processWithCipher cipher origSkx
where
processWithCipher :: Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
skx =
case (Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher, ServerKeyXchgAlgorithmData
skx) of
(CipherKeyExchangeType
CipherKeyExchange_DHE_RSA, SKX_DHE_RSA ServerDHParams
dhparams DigitallySigned
signature) ->
ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_RSA
(CipherKeyExchangeType
CipherKeyExchange_DHE_DSA, SKX_DHE_DSA ServerDHParams
dhparams DigitallySigned
signature) ->
ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_DSA
(CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ServerECDHParams
ecdhparams DigitallySigned
signature) ->
ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_RSA
(CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ServerECDHParams
ecdhparams DigitallySigned
signature) ->
ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_ECDSA
(CipherKeyExchangeType
cke, SKX_Unparsed ByteString
bytes) -> do
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of
Left TLSError
_ ->
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol
(String
"unknown server key exchange received, expecting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CipherKeyExchangeType -> String
forall a. Show a => a -> String
show CipherKeyExchangeType
cke)
AlertDescription
HandshakeFailure
Right ServerKeyXchgAlgorithmData
realSkx -> Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
realSkx
(CipherKeyExchangeType
c, ServerKeyXchgAlgorithmData
_) ->
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol
(String
"unknown server key exchange received, expecting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CipherKeyExchangeType -> String
forall a. Show a => a -> String
show CipherKeyExchangeType
c)
AlertDescription
HandshakeFailure
doDHESignature :: ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
kxsAlg = do
publicKey <- KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg
verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature
unless verified $
decryptError
("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams)
usingHState ctx $ setServerDHParams dhparams
doECDHESignature :: ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
kxsAlg = do
publicKey <- KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg
verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature
unless verified $
decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams")
usingHState ctx $ setServerECDHParams ecdhparams
getSignaturePublicKey :: KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg = do
publicKey <- Context -> HandshakeM PubKey -> IO PubKey
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM PubKey
getRemotePublicKey
unless (isKeyExchangeSignatureKey kxsAlg publicKey) $
throwCore $
Error_Protocol
("server public key algorithm is incompatible with " ++ show kxsAlg)
HandshakeFailure
ver <- usingState_ ctx getVersion
unless (publicKey `versionCompatible` ver) $
throwCore $
Error_Protocol
(show ver ++ " has no support for " ++ pubkeyType publicKey)
IllegalParameter
let groups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
unless (satisfiesEcPredicate (`elem` groups) publicKey) $
throwCore $
Error_Protocol
"server public key has unsupported elliptic curve"
IllegalParameter
return publicKey
doCertificate :: ClientParams -> Context -> CertificateChain -> IO ()
doCertificate :: ClientParams -> Context -> CertificateChain -> IO ()
doCertificate ClientParams
cparams Context
ctx CertificateChain
certs = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol String
"server certificate missing" AlertDescription
DecodeError
Context -> (Hooks -> IO ()) -> IO ()
forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx (Hooks -> CertificateChain -> IO ()
`hookRecvCertificates` CertificateChain
certs)
usage <- IO CertificateUsage
-> (SomeException -> IO CertificateUsage) -> IO CertificateUsage
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([FailedReason] -> CertificateUsage
wrapCertificateChecks ([FailedReason] -> CertificateUsage)
-> IO [FailedReason] -> IO CertificateUsage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FailedReason]
checkCert) SomeException -> IO CertificateUsage
rejectOnException
case usage of
CertificateUsage
CertificateUsageAccept -> IO ()
checkLeafCertificateKeyUsage
CertificateUsageReject CertificateRejectReason
reason -> CertificateRejectReason -> IO ()
forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
certificateRejected CertificateRejectReason
reason
where
shared :: Shared
shared = ClientParams -> Shared
clientShared ClientParams
cparams
checkCert :: IO [FailedReason]
checkCert =
ClientHooks -> OnServerCertificate
onServerCertificate
(ClientParams -> ClientHooks
clientHooks ClientParams
cparams)
(Shared -> CertificateStore
sharedCAStore Shared
shared)
(Shared -> ValidationCache
sharedValidationCache Shared
shared)
(ClientParams -> (String, ByteString)
clientServerIdentification ClientParams
cparams)
CertificateChain
certs
checkLeafCertificateKeyUsage :: IO ()
checkLeafCertificateKeyUsage = do
cipher <- Context -> HandshakeM Cipher -> IO Cipher
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
case requiredCertKeyUsage cipher of
[] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[ExtKeyUsageFlag]
flags -> [ExtKeyUsageFlag] -> CertificateChain -> IO ()
forall (m :: * -> *).
MonadIO m =>
[ExtKeyUsageFlag] -> CertificateChain -> m ()
verifyLeafKeyUsage [ExtKeyUsageFlag]
flags CertificateChain
certs
requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage Cipher
cipher =
case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
CipherKeyExchangeType
CipherKeyExchange_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> []
CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_DHE_DSA -> [ExtKeyUsageFlag
KeyUsage_digitalSignature]
CipherKeyExchangeType
CipherKeyExchange_DH_DSA -> [ExtKeyUsageFlag
KeyUsage_keyAgreement]
CipherKeyExchangeType
CipherKeyExchange_DH_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_ECDH_ECDSA -> [ExtKeyUsageFlag
KeyUsage_keyAgreement]
CipherKeyExchangeType
CipherKeyExchange_ECDH_RSA -> [ExtKeyUsageFlag]
rsaCompatibility
CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> [ExtKeyUsageFlag
KeyUsage_digitalSignature]
CipherKeyExchangeType
CipherKeyExchange_TLS13 -> [ExtKeyUsageFlag
KeyUsage_digitalSignature]
where
rsaCompatibility :: [ExtKeyUsageFlag]
rsaCompatibility =
[ ExtKeyUsageFlag
KeyUsage_digitalSignature
, ExtKeyUsageFlag
KeyUsage_keyEncipherment
, ExtKeyUsageFlag
KeyUsage_keyAgreement
]
supportedCtypes
:: [HashAndSignatureAlgorithm]
-> [CertificateType]
supportedCtypes :: [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes [HashAndSignatureAlgorithm]
hashAlgs =
[CertificateType] -> [CertificateType]
forall a. Eq a => [a] -> [a]
nub ([CertificateType] -> [CertificateType])
-> [CertificateType] -> [CertificateType]
forall a b. (a -> b) -> a -> b
$ (HashAndSignatureAlgorithm
-> [CertificateType] -> [CertificateType])
-> [CertificateType]
-> [HashAndSignatureAlgorithm]
-> [CertificateType]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HashAndSignatureAlgorithm -> [CertificateType] -> [CertificateType]
ctfilter [] [HashAndSignatureAlgorithm]
hashAlgs
where
ctfilter :: HashAndSignatureAlgorithm -> [CertificateType] -> [CertificateType]
ctfilter HashAndSignatureAlgorithm
x [CertificateType]
acc = case HashAndSignatureAlgorithm -> Maybe CertificateType
hashSigToCertType HashAndSignatureAlgorithm
x of
Just CertificateType
cType
| CertificateType
cType CertificateType -> CertificateType -> Bool
forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType ->
CertificateType
cType CertificateType -> [CertificateType] -> [CertificateType]
forall a. a -> [a] -> [a]
: [CertificateType]
acc
Maybe CertificateType
_ -> [CertificateType]
acc
clientSupportedCtypes
:: Context
-> [CertificateType]
clientSupportedCtypes :: Context -> [CertificateType]
clientSupportedCtypes Context
ctx =
[HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes ([HashAndSignatureAlgorithm] -> [CertificateType])
-> [HashAndSignatureAlgorithm] -> [CertificateType]
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
sigAlgsToCertTypes
:: Context
-> [HashAndSignatureAlgorithm]
-> [CertificateType]
sigAlgsToCertTypes :: Context -> [HashAndSignatureAlgorithm] -> [CertificateType]
sigAlgsToCertTypes Context
ctx [HashAndSignatureAlgorithm]
hashSigs =
(CertificateType -> Bool) -> [CertificateType] -> [CertificateType]
forall a. (a -> Bool) -> [a] -> [a]
filter (CertificateType -> [CertificateType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes [HashAndSignatureAlgorithm]
hashSigs) ([CertificateType] -> [CertificateType])
-> [CertificateType] -> [CertificateType]
forall a b. (a -> b) -> a -> b
$ Context -> [CertificateType]
clientSupportedCtypes Context
ctx
clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx =
Context
-> HandshakeM (Maybe CertReqCBdata) -> IO (Maybe CertReqCBdata)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertReqCBdata)
getCertReqCBdata IO (Maybe CertReqCBdata)
-> (Maybe CertReqCBdata -> IO (Maybe CertificateChain))
-> IO (Maybe CertificateChain)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe CertReqCBdata
Nothing -> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CertificateChain
forall a. Maybe a
Nothing
Just CertReqCBdata
cbdata -> do
let callback :: OnCertificateRequest
callback = ClientHooks -> OnCertificateRequest
onCertificateRequest (ClientHooks -> OnCertificateRequest)
-> ClientHooks -> OnCertificateRequest
forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cparams
chain <-
IO (Maybe (CertificateChain, PrivKey))
-> IO (Maybe (CertificateChain, PrivKey))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (CertificateChain, PrivKey))
-> IO (Maybe (CertificateChain, PrivKey)))
-> IO (Maybe (CertificateChain, PrivKey))
-> IO (Maybe (CertificateChain, PrivKey))
forall a b. (a -> b) -> a -> b
$
OnCertificateRequest
callback CertReqCBdata
cbdata
IO (Maybe (CertificateChain, PrivKey))
-> (SomeException -> IO (Maybe (CertificateChain, PrivKey)))
-> IO (Maybe (CertificateChain, PrivKey))
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException` String -> SomeException -> IO (Maybe (CertificateChain, PrivKey))
forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
"certificate request callback failed"
case chain of
Maybe (CertificateChain, PrivKey)
Nothing ->
Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CertificateChain -> IO (Maybe CertificateChain))
-> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Maybe CertificateChain
forall a. a -> Maybe a
Just (CertificateChain -> Maybe CertificateChain)
-> CertificateChain -> Maybe CertificateChain
forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
Just (CertificateChain [], PrivKey
_) ->
Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CertificateChain -> IO (Maybe CertificateChain))
-> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Maybe CertificateChain
forall a. a -> Maybe a
Just (CertificateChain -> Maybe CertificateChain)
-> CertificateChain -> Maybe CertificateChain
forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
Just cred :: (CertificateChain, PrivKey)
cred@(CertificateChain
cc, PrivKey
_) ->
do
let ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
_, [DistinguishedName]
_) = CertReqCBdata
cbdata
Context
-> [CertificateType] -> (CertificateChain, PrivKey) -> IO ()
storePrivInfoClient Context
ctx [CertificateType]
cTypes (CertificateChain, PrivKey)
cred
Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CertificateChain -> IO (Maybe CertificateChain))
-> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Maybe CertificateChain
forall a. a -> Maybe a
Just CertificateChain
cc
storePrivInfoClient
:: Context
-> [CertificateType]
-> Credential
-> IO ()
storePrivInfoClient :: Context
-> [CertificateType] -> (CertificateChain, PrivKey) -> IO ()
storePrivInfoClient Context
ctx [CertificateType]
cTypes (CertificateChain
cc, PrivKey
privkey) = do
pubkey <- Context -> CertificateChain -> PrivKey -> IO PubKey
forall (m :: * -> *).
MonadIO m =>
Context -> CertificateChain -> PrivKey -> m PubKey
storePrivInfo Context
ctx CertificateChain
cc PrivKey
privkey
unless (certificateCompatible pubkey cTypes) $
throwCore $
Error_Protocol
(pubkeyType pubkey ++ " credential does not match allowed certificate types")
InternalError
ver <- usingState_ ctx getVersion
unless (pubkey `versionCompatible` ver) $
throwCore $
Error_Protocol
(pubkeyType pubkey ++ " credential is not supported at version " ++ show ver)
InternalError
getLocalHashSigAlg
:: Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg :: Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
isCompatible [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey = do
(Just (_, Just hashSigs, _)) <- Context
-> HandshakeM (Maybe CertReqCBdata) -> IO (Maybe CertReqCBdata)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertReqCBdata)
getCertReqCBdata
let want =
Bool -> Bool -> Bool
(&&)
(Bool -> Bool -> Bool)
-> (HashAndSignatureAlgorithm -> Bool)
-> HashAndSignatureAlgorithm
-> Bool
-> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PubKey -> HashAndSignatureAlgorithm -> Bool
isCompatible PubKey
pubKey
(HashAndSignatureAlgorithm -> Bool -> Bool)
-> (HashAndSignatureAlgorithm -> Bool)
-> HashAndSignatureAlgorithm
-> Bool
forall a b.
(HashAndSignatureAlgorithm -> a -> b)
-> (HashAndSignatureAlgorithm -> a)
-> HashAndSignatureAlgorithm
-> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (HashAndSignatureAlgorithm -> [HashAndSignatureAlgorithm] -> Bool)
-> [HashAndSignatureAlgorithm] -> HashAndSignatureAlgorithm -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip HashAndSignatureAlgorithm -> [HashAndSignatureAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [HashAndSignatureAlgorithm]
hashSigs
case find want cHashSigs of
Just HashAndSignatureAlgorithm
best -> HashAndSignatureAlgorithm -> IO HashAndSignatureAlgorithm
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HashAndSignatureAlgorithm
best
Maybe HashAndSignatureAlgorithm
Nothing -> TLSError -> IO HashAndSignatureAlgorithm
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO HashAndSignatureAlgorithm)
-> TLSError -> IO HashAndSignatureAlgorithm
forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol (PubKey -> String
keyerr PubKey
pubKey) AlertDescription
HandshakeFailure
where
keyerr :: PubKey -> String
keyerr PubKey
k = String
"no " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" hash algorithm in common with the server"
setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
msgt [ExtensionRaw]
exts = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_ApplicationLayerProtocolNegotiation [ExtensionRaw]
exts
Maybe ByteString
-> (ByteString -> Maybe ApplicationLayerProtocolNegotiation)
-> Maybe ApplicationLayerProtocolNegotiation
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType
-> ByteString -> Maybe ApplicationLayerProtocolNegotiation
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
msgt of
Just (ApplicationLayerProtocolNegotiation [ByteString
proto]) -> 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
mprotos <- TLSSt (Maybe [ByteString])
getClientALPNSuggest
case mprotos of
Just [ByteString]
protos -> Bool -> TLSSt () -> TLSSt ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
proto ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
protos) (TLSSt () -> TLSSt ()) -> TLSSt () -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> TLSSt ()
setExtensionALPN Bool
True
ByteString -> TLSSt ()
setNegotiatedProtocol ByteString
proto
Maybe [ByteString]
_ -> () -> TLSSt ()
forall a. a -> TLSSt a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe ApplicationLayerProtocolNegotiation
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
contextSync :: Context -> ClientState -> IO ()
contextSync :: Context -> ClientState -> IO ()
contextSync Context
ctx ClientState
ctl = case Context -> HandshakeSync
ctxHandshakeSync Context
ctx of
HandshakeSync Context -> ClientState -> IO ()
sync Context -> ServerState -> IO ()
_ -> Context -> ClientState -> IO ()
sync Context
ctx ClientState
ctl
clientSessions :: ClientParams -> [(SessionID, SessionData)]
clientSessions :: ClientParams -> [(ByteString, SessionData)]
clientSessions ClientParams{Bool
[(ByteString, SessionData)]
Maybe (ByteString, SessionData)
Maybe MaxFragmentEnum
(String, ByteString)
ClientHooks
Shared
Supported
DebugParams
clientShared :: ClientParams -> Shared
clientHooks :: ClientParams -> ClientHooks
clientServerIdentification :: ClientParams -> (String, ByteString)
clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
clientServerIdentification :: (String, ByteString)
clientUseServerNameIndication :: Bool
clientWantSessionResume :: Maybe (ByteString, SessionData)
clientWantSessionResumeList :: [(ByteString, SessionData)]
clientShared :: Shared
clientHooks :: ClientHooks
clientSupported :: Supported
clientDebug :: DebugParams
clientUseEarlyData :: Bool
clientUseEarlyData :: ClientParams -> Bool
clientDebug :: ClientParams -> DebugParams
clientSupported :: ClientParams -> Supported
clientWantSessionResumeList :: ClientParams -> [(ByteString, SessionData)]
clientWantSessionResume :: ClientParams -> Maybe (ByteString, SessionData)
clientUseServerNameIndication :: ClientParams -> Bool
clientUseMaxFragmentLength :: ClientParams -> Maybe MaxFragmentEnum
..} = case Maybe (ByteString, SessionData)
clientWantSessionResume of
Maybe (ByteString, SessionData)
Nothing -> [(ByteString, SessionData)]
clientWantSessionResumeList
Just (ByteString, SessionData)
ent -> [(ByteString, SessionData)]
clientWantSessionResumeList [(ByteString, SessionData)]
-> [(ByteString, SessionData)] -> [(ByteString, SessionData)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, SessionData)
ent]