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
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Orphan instances.
module X509.Instances
( arbitraryOID
, arbitraryRSA
, arbitraryLargeRSA
, arbitraryDSA
, arbitraryNamedEC
, arbitraryX25519
, arbitraryX448
, arbitraryEd25519
, arbitraryEd448
, arbitrarySignedCertificate
, arbitraryCertificateChain
, shuffleCertificateChain
) where
import Control.Monad (zipWithM)
import Data.ASN1.Types
import qualified Data.ByteArray as B
import Data.Hourglass
import Data.List (nub)
import Data.X509
import Test.Tasty.QuickCheck
import Crypto.Number.Serialize (i2ospOf_)
import qualified Crypto.PubKey.Curve25519 as X25519
import qualified Crypto.PubKey.Curve448 as X448
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Generate as ECC
import qualified Crypto.PubKey.ECC.Types as ECC
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA as RSA
import Crypto.Random
-- Warning: not a cryptographic implementation, used for tests only
instance MonadRandom Gen where
getRandomBytes n = B.pack <$> vector n
arbitraryOID :: Gen [Integer]
arbitraryOID = do
o1 <- choose (0,6)
o2 <- choose (0,15)
os <- resize 5 $ listOf (getPositive <$> arbitrary)
return (o1 : o2 : os)
arbitraryDN :: Gen DistinguishedName
arbitraryDN = DistinguishedName <$> resize 5 (listOf1 arbitraryDE)
where
arbitrarySE = elements [IA5, UTF8]
arbitraryDE = (,) <$> arbitraryOID <*> arbitraryCS
arbitraryCS = ASN1CharacterString <$> arbitrarySE <*> arbitraryBS
arbitraryBS = resize 16 (B.pack <$> listOf1 arbitrary)
instance Arbitrary PubKey where
arbitrary = oneof [ PubKeyRSA . fst <$> arbitraryRSA
, PubKeyDSA . fst <$> arbitraryDSA
, PubKeyEC . fst <$> arbitraryNamedEC
--, PubKeyEC . fst <$> arbitraryExplicitPrimeCurve
, PubKeyX25519 . fst <$> arbitraryX25519
, PubKeyX448 . fst <$> arbitraryX448
, PubKeyEd25519 . fst <$> arbitraryEd25519
, PubKeyEd448 . fst <$> arbitraryEd448
]
instance Arbitrary PrivKey where
arbitrary = oneof [ PrivKeyRSA . snd <$> arbitraryRSA
, PrivKeyDSA . snd <$> arbitraryDSA
, PrivKeyEC . snd <$> arbitraryNamedEC
, PrivKeyEC . snd <$> arbitraryExplicitPrimeCurve
, PrivKeyX25519 . snd <$> arbitraryX25519
, PrivKeyX448 . snd <$> arbitraryX448
, PrivKeyEd25519 . snd <$> arbitraryEd25519
, PrivKeyEd448 . snd <$> arbitraryEd448
]
arbitraryRSA :: Gen (RSA.PublicKey, RSA.PrivateKey)
arbitraryRSA = do
n <- elements [ 768, 1024 ] -- enough bits to sign with SHA-512
e <- elements [ 3, 0x10001 ]
RSA.generate (n `div` 8) e
arbitraryLargeRSA :: Gen (RSA.PublicKey, RSA.PrivateKey)
arbitraryLargeRSA = do
n <- elements [ 1792, 2048 ] -- enough bits for RSA-OAEP with SHA-512
e <- elements [ 3, 0x10001 ]
RSA.generate (n `div` 8) e
arbitraryDSA :: Gen (DSA.PublicKey, DSA.PrivateKey)
arbitraryDSA = do
x <- DSA.generatePrivate params
let y = DSA.calculatePublic params x
priv = DSA.PrivateKey { DSA.private_params = params, DSA.private_x = x }
pub = DSA.PublicKey { DSA.public_params = params, DSA.public_y = y }
return (pub, priv)
where
-- DSA parameters were generated using 'openssl dsaparam -C 2048'
params = DSA.Params
{ DSA.params_p = 0x9994B9B1FC22EC3A5F607B5130D314F35FC8D387015A6D8FA2B56D3CC1F13FE330A631DBC765CEFFD6986BDEB8512580BBAD93D56EE7A8997DB9C65C29313FBC5077DB6F1E9D9E6D3499F997F09C8CF8ECC9E5F38DC34C3D656CFDF463893DDF9E246E223D7E5C4E86F54426DDA5DE112FCEDBFB5B6D6F7C76ED190EA1A7761CA561E8E5803F9D616DAFF25E2CCD4011A6D78D5CE8ED28CC2D865C7EC01508BA96FBD1F8BB5E517B6A5208A90AC2D3DCAE50281C02510B86C16D449465CD4B3754FD91AA19031282122A25C68292F033091FCB9DEBDE0D220F81F7EE4AB6581D24BE48204AF3DA52BDB944DA53B76148055395B30954735DC911574D360C953B
, DSA.params_g = 0x10E51AEA37880C5E52DD477ED599D55050C47012D038B9E4B3199C9DE9A5B873B1ABC8B954F26AFEA6C028BCE1783CFE19A88C64E4ED6BFD638802A78457A5C25ABEA98BE9C6EF18A95504C324315EABE7C1EA50E754591E3EFD3D33D4AE47F82F8978ABC871C135133767ACC60683F065430C749C43893D73596B12D5835A78778D0140B2F63B32A5658308DD5BA6BBC49CF6692929FA6A966419404F9A2C216860E3F339EDDB49AD32C294BDB4C9C6BB0D1CC7B691C65968C3A0A5106291CD3810147C8A16B4BFE22968AD9D3890733F4AA9ACD8687A5B981653A4B1824004639956E8C1EDAF31A8224191E8ABD645D2901F5B164B4B93F98039A6EAEC6088
, DSA.params_q = 0xE1FDFADD32F46B5035EEB3DB81F9974FBCA69BE2223E62FCA8C77989B2AACDF7
}
arbitraryNamedEC :: Gen (PubKeyEC, PrivKeyEC)
arbitraryNamedEC = do
name <- arbitraryCurveName
let curve = ECC.getCurveByName name
pair <- ECC.generate curve
let d = ECDSA.private_d (snd pair)
priv = PrivKeyEC_Named { privkeyEC_name = name, privkeyEC_priv = d }
q = ECDSA.public_q (fst pair)
pt = getSerializedPoint curve q
pub = PubKeyEC_Named { pubkeyEC_name = name, pubkeyEC_pub = pt }
return (pub, priv)
arbitraryExplicitPrimeCurve :: Gen (PubKeyEC, PrivKeyEC)
arbitraryExplicitPrimeCurve = do
curve <- arbitraryPrimeCurve
pair <- ECC.generate curve
let cc = ECC.common_curve curve
c = fp curve
gen = getSerializedPoint curve (ECC.ecc_g cc)
d = ECDSA.private_d (snd pair)
priv =
PrivKeyEC_Prime
{ privkeyEC_priv = d
, privkeyEC_a = ECC.ecc_a cc
, privkeyEC_b = ECC.ecc_b cc
, privkeyEC_prime = ECC.ecc_p c
, privkeyEC_generator = gen
, privkeyEC_order = ECC.ecc_n cc
, privkeyEC_cofactor = ECC.ecc_h cc
, privkeyEC_seed = 0
}
q = ECDSA.public_q (fst pair)
pt = getSerializedPoint curve q
pub =
PubKeyEC_Prime
{ pubkeyEC_pub = pt
, pubkeyEC_a = ECC.ecc_a cc
, pubkeyEC_b = ECC.ecc_b cc
, pubkeyEC_prime = ECC.ecc_p c
, pubkeyEC_generator = gen
, pubkeyEC_order = ECC.ecc_n cc
, pubkeyEC_cofactor = ECC.ecc_h cc
, pubkeyEC_seed = 0
}
return (pub, priv)
where
fp (ECC.CurveFP c) = c
fp _ = error "arbitraryExplicitPrimeCurve: assumption failed"
arbitraryCurveName :: Gen ECC.CurveName
arbitraryCurveName = elements allCurveNames
allCurveNames :: [ECC.CurveName]
allCurveNames =
[ ECC.SEC_p112r1
, ECC.SEC_p112r2
, ECC.SEC_p128r1
, ECC.SEC_p128r2
, ECC.SEC_p160k1
, ECC.SEC_p160r1
, ECC.SEC_p160r2
, ECC.SEC_p192k1
, ECC.SEC_p192r1
, ECC.SEC_p224k1
, ECC.SEC_p224r1
, ECC.SEC_p256k1
, ECC.SEC_p256r1
, ECC.SEC_p384r1
, ECC.SEC_p521r1
, ECC.SEC_t113r1
, ECC.SEC_t113r2
, ECC.SEC_t131r1
, ECC.SEC_t131r2
, ECC.SEC_t163k1
, ECC.SEC_t163r1
, ECC.SEC_t163r2
, ECC.SEC_t193r1
, ECC.SEC_t193r2
, ECC.SEC_t233k1
, ECC.SEC_t233r1
, ECC.SEC_t239k1
, ECC.SEC_t283k1
, ECC.SEC_t283r1
, ECC.SEC_t409k1
, ECC.SEC_t409r1
, ECC.SEC_t571k1
, ECC.SEC_t571r1
]
primeCurves :: [ECC.Curve]
primeCurves = filter isPrimeCurve $ map ECC.getCurveByName allCurveNames
where isPrimeCurve (ECC.CurveFP _) = True
isPrimeCurve _ = False
arbitraryPrimeCurve :: Gen ECC.Curve
arbitraryPrimeCurve = elements primeCurves
getSerializedPoint :: ECC.Curve -> ECC.Point -> SerializedPoint
getSerializedPoint curve pt = SerializedPoint (serializePoint pt)
where
bs = i2ospOf_ (curveSizeBytes curve)
serializePoint ECC.PointO = B.singleton 0
serializePoint (ECC.Point x y) = B.cons 4 (B.append (bs x) (bs y))
curveSizeBytes :: ECC.Curve -> Int
curveSizeBytes curve = (ECC.curveSizeBits curve + 7) `div` 8
arbitraryX25519 :: Gen (X25519.PublicKey, X25519.SecretKey)
arbitraryX25519 = do
priv <- X25519.generateSecretKey
return (X25519.toPublic priv, priv)
arbitraryX448 :: Gen (X448.PublicKey, X448.SecretKey)
arbitraryX448 = do
priv <- X448.generateSecretKey
return (X448.toPublic priv, priv)
arbitraryEd25519 :: Gen (Ed25519.PublicKey, Ed25519.SecretKey)
arbitraryEd25519 = do
priv <- Ed25519.generateSecretKey
return (Ed25519.toPublic priv, priv)
arbitraryEd448 :: Gen (Ed448.PublicKey, Ed448.SecretKey)
arbitraryEd448 = do
priv <- Ed448.generateSecretKey
return (Ed448.toPublic priv, priv)
instance Arbitrary SignatureALG where
arbitrary = elements
[ SignatureALG HashSHA1 PubKeyALG_RSA
, SignatureALG HashMD5 PubKeyALG_RSA
, SignatureALG HashMD2 PubKeyALG_RSA
, SignatureALG HashSHA256 PubKeyALG_RSA
, SignatureALG HashSHA384 PubKeyALG_RSA
, SignatureALG HashSHA512 PubKeyALG_RSA
, SignatureALG HashSHA224 PubKeyALG_RSA
, SignatureALG HashSHA1 PubKeyALG_DSA
, SignatureALG HashSHA224 PubKeyALG_DSA
, SignatureALG HashSHA256 PubKeyALG_DSA
, SignatureALG HashSHA224 PubKeyALG_EC
, SignatureALG HashSHA256 PubKeyALG_EC
, SignatureALG HashSHA384 PubKeyALG_EC
, SignatureALG HashSHA512 PubKeyALG_EC
, SignatureALG_IntrinsicHash PubKeyALG_Ed25519
, SignatureALG_IntrinsicHash PubKeyALG_Ed448
]
instance Arbitrary DateTime where
arbitrary =
let arbitraryElapsed = Elapsed . Seconds <$> choose (1, 100000000)
in timeConvert <$> arbitraryElapsed
arbitraryCertificateWithDNs :: PubKey
-> DistinguishedName -- issuer
-> DistinguishedName -- subject
-> Gen Certificate
arbitraryCertificateWithDNs pubKey issuerDN subjectDN =
Certificate <$> pure 2
<*> arbitrary
<*> arbitrary
<*> pure issuerDN
<*> arbitrary
<*> pure subjectDN
<*> pure pubKey
<*> pure (Extensions Nothing)
arbitraryCertificate :: PubKey -> Gen Certificate
arbitraryCertificate pubKey = do
issuerDN <- arbitraryDN
subjectDN <- arbitraryDN
arbitraryCertificateWithDNs pubKey issuerDN subjectDN
instance Arbitrary Certificate where
arbitrary = arbitrary >>= arbitraryCertificate
instance Arbitrary RevokedCertificate where
arbitrary = RevokedCertificate <$> arbitrary
<*> arbitrary
<*> pure (Extensions Nothing)
instance Arbitrary CRL where
arbitrary = CRL <$> pure 1
<*> arbitrary
<*> arbitraryDN
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> pure (Extensions Nothing)
arbitrarySignedExact :: (Show a, Eq a, ASN1Object a)
=> a -> Gen (SignedExact a)
arbitrarySignedExact = objectToSignedExactF doSign
where
doSign _ = (,) <$> arbitrarySig <*> arbitrary
arbitrarySig = B.pack <$> vector 16
arbitrarySignedCertificate :: PubKey -> Gen SignedCertificate
arbitrarySignedCertificate pubKey =
arbitraryCertificate pubKey >>= arbitrarySignedExact
instance (Show a, Eq a, ASN1Object a, Arbitrary a) => Arbitrary (SignedExact a) where
arbitrary = arbitrary >>= arbitrarySignedExact
arbitraryCertificateChain :: PubKey -> Gen CertificateChain
arbitraryCertificateChain pubKey = do
rootDN <- arbitraryDN
otherDNs <- nub <$> resize 3 (listOf (arbitraryDN `suchThat` (/= rootDN)))
if null otherDNs
then do
root <- generateCert pubKey (rootDN, rootDN)
return $ CertificateChain [root]
else do
rootKey <- arbitrary
root <- generateCert rootKey (rootDN, rootDN)
let dnPairs = zip (rootDN : otherDNs) otherDNs -- (issuer, subject)
keys <- vectorOf (length otherDNs - 1) arbitrary
certs <- zipWithM generateCert (keys ++ [pubKey]) dnPairs
return $ CertificateChain $ reverse (root : certs)
where
generateCert key (issuerDN, subjectDN) =
arbitraryCertificateWithDNs key issuerDN subjectDN
>>= arbitrarySignedExact
shuffleCertificateChain :: CertificateChain -> Gen CertificateChain
shuffleCertificateChain (CertificateChain []) = error "empty certificate chain"
shuffleCertificateChain (CertificateChain (leaf : auths)) =
CertificateChain . (leaf :) <$> shuffle auths
|
