1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Server.Common (
applicationProtocol,
checkValidClientCertChain,
clientCertificate,
credentialDigitalSignatureKey,
filterCredentials,
filterCredentialsWithHashSignatures,
makeCredentialPredicate,
isCredentialAllowed,
storePrivInfoServer,
hashAndSignaturesInCommon,
processRecordSizeLimit,
) where
import Control.Monad.State.Strict
import Data.X509 (ExtKeyUsageFlag (..))
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.Key
import Network.TLS.Handshake.State
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Util (catchException)
import Network.TLS.X509
checkValidClientCertChain
:: MonadIO m => Context -> String -> m CertificateChain
checkValidClientCertChain ctx errmsg = do
chain <- usingHState ctx getClientCertChain
let throwerror = Error_Protocol errmsg UnexpectedMessage
case chain of
Nothing -> throwCore throwerror
Just cc
| isNullCertificateChain cc -> throwCore throwerror
| otherwise -> return cc
credentialDigitalSignatureKey :: Credential -> Maybe PubKey
credentialDigitalSignatureKey cred
| isDigitalSignaturePair keys = Just pubkey
| otherwise = Nothing
where
keys@(pubkey, _) = credentialPublicPrivateKeys cred
filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials
filterCredentials p (Credentials l) = Credentials (filter p l)
-- ECDSA keys are tested against supported elliptic curves until TLS12 but
-- not after. With TLS13, the curve is linked to the signature algorithm
-- and client support is tested with signatureCompatible13.
makeCredentialPredicate :: Version -> [ExtensionRaw] -> (Group -> Bool)
makeCredentialPredicate ver exts
| ver >= TLS13 = const True
| otherwise =
lookupAndDecode
EID_SupportedGroups
MsgTClientHello
exts
(const True)
(\(SupportedGroups sg) -> (`elem` sg))
isCredentialAllowed :: Version -> (Group -> Bool) -> Credential -> Bool
isCredentialAllowed ver p cred =
pubkey `versionCompatible` ver && satisfiesEcPredicate p pubkey
where
(pubkey, _) = credentialPublicPrivateKeys cred
-- Filters a list of candidate credentials with credentialMatchesHashSignatures.
--
-- Algorithms to filter with are taken from "signature_algorithms_cert"
-- extension when it exists, else from "signature_algorithms" when clients do
-- not implement the new extension (see RFC 8446 section 4.2.3).
--
-- Resulting credential list can be used as input to the hybrid cipher-and-
-- certificate selection for TLS12, or to the direct certificate selection
-- simplified with TLS13. As filtering credential signatures with client-
-- advertised algorithms is not supposed to cause negotiation failure, in case
-- of dead end with the subsequent selection process, this process should always
-- be restarted with the unfiltered credential list as input (see fallback
-- certificate chains, described in same RFC section).
--
-- Calling code should not forget to apply constraints of extension
-- "signature_algorithms" to any signature-based key exchange derived from the
-- output credentials. Respecting client constraints on KX signatures is
-- mandatory but not implemented by this function.
filterCredentialsWithHashSignatures
:: [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures exts =
lookupAndDecode
EID_SignatureAlgorithmsCert
MsgTClientHello
exts
lookupSignatureAlgorithms
(\(SignatureAlgorithmsCert sas) -> withAlgs sas)
where
lookupSignatureAlgorithms =
lookupAndDecode
EID_SignatureAlgorithms
MsgTClientHello
exts
id
(\(SignatureAlgorithms sas) -> withAlgs sas)
withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas)
storePrivInfoServer :: MonadIO m => Context -> Credential -> m ()
storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey)
-- ALPN (Application Layer Protocol Negotiation)
applicationProtocol
:: Context -> [ExtensionRaw] -> ServerParams -> IO (Maybe ExtensionRaw)
applicationProtocol ctx exts sparams = case onALPN of
Nothing -> return Nothing
Just io ->
lookupAndDecodeAndDo
EID_ApplicationLayerProtocolNegotiation
MsgTClientHello
exts
(return Nothing)
$ select io
where
onALPN = onALPNClientSuggest $ serverHooks sparams
select io (ApplicationLayerProtocolNegotiation protos) = do
proto <- io protos
when (proto == "") $
throwCore $
Error_Protocol "no supported application protocols" NoApplicationProtocol
usingState_ ctx $ do
setExtensionALPN True
setNegotiatedProtocol proto
let alpn = ApplicationLayerProtocolNegotiation [proto]
return $ Just $ toExtensionRaw alpn
clientCertificate :: ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate sparams ctx certs = do
-- run certificate recv hook
ctxWithHooks ctx (`hookRecvCertificates` certs)
-- Call application callback to see whether the
-- certificate chain is acceptable.
--
usage <-
liftIO $
catchException
(onClientCertificate (serverHooks sparams) certs)
rejectOnException
case usage of
CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs
CertificateUsageReject reason -> certificateRejected reason
-- Remember cert chain for later use.
--
usingHState ctx $ setClientCertChain certs
----------------------------------------------------------------
-- The values in the "signature_algorithms" extension
-- are in descending order of preference.
-- However here the algorithms are selected according
-- to server preference in 'supportedHashSignatures'.
hashAndSignaturesInCommon
:: [HashAndSignatureAlgorithm] -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon sHashSigs exts = sHashSigs `intersect` cHashSigs
where
-- See Section 7.4.1.4.1 of RFC 5246.
defVal =
[ (HashSHA1, SignatureECDSA)
, (HashSHA1, SignatureRSA)
, (HashSHA1, SignatureDSA)
]
cHashSigs =
lookupAndDecode
EID_SignatureAlgorithms
MsgTClientHello
exts
defVal
(\(SignatureAlgorithms sas) -> sas)
processRecordSizeLimit
:: Context -> [ExtensionRaw] -> Bool -> IO (Maybe ExtensionRaw)
processRecordSizeLimit ctx chExts tls13 = do
let mmylim = limitRecordSize $ sharedLimit $ ctxShared ctx
setMyRecordLimit ctx mmylim
case mmylim of
Nothing -> return Nothing
Just mylim -> do
lookupAndDecodeAndDo
EID_RecordSizeLimit
MsgTClientHello
chExts
(return ())
(setPeerRecordSizeLimit ctx tls13)
peerSentRSL <- checkPeerRecordLimit ctx
if peerSentRSL
then do
let mysiz = fromIntegral mylim + if tls13 then 1 else 0
rsl = RecordSizeLimit mysiz
return $ Just $ toExtensionRaw rsl
else return Nothing
|
