cryptostore-0.2.0.0: tests/X509/Instances.hs
{-# 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 []) = fail "empty certificate chain"
shuffleCertificateChain (CertificateChain (leaf : auths)) =
CertificateChain . (leaf :) <$> shuffle auths