cryptostore-0.1.0.0: tests/X509/Instances.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Orphan instances.
module X509.Instances
( arbitraryOID
, arbitraryRSA
, arbitraryLargeRSA
, arbitraryDSA
, arbitraryNamedEC
, arbitrarySignedCertificate
, arbitraryCertificateChain
) where
import Data.ASN1.Types
import qualified Data.ByteArray as B
import Data.Hourglass
import Data.X509
import Test.Tasty.QuickCheck
import Crypto.Number.Serialize (i2ospOf_)
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.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
]
instance Arbitrary PrivKey where
arbitrary = oneof [ PrivKeyRSA . snd <$> arbitraryRSA
, PrivKeyDSA . snd <$> arbitraryDSA
, PrivKeyEC . snd <$> arbitraryNamedEC
, PrivKeyEC . snd <$> arbitraryExplicitPrimeCurve
]
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
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
]
instance Arbitrary DateTime where
arbitrary =
let arbitraryElapsed = Elapsed . Seconds <$> choose (1, 100000000)
in timeConvert <$> arbitraryElapsed
arbitraryCertificate :: PubKey -> Gen Certificate
arbitraryCertificate pubKey =
Certificate <$> pure 2
<*> arbitrary
<*> arbitrary
<*> arbitraryDN
<*> arbitrary
<*> arbitraryDN
<*> pure pubKey
<*> pure (Extensions Nothing)
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
leaf <- arbitrarySignedCertificate pubKey
others <- resize 3 $ listOf (arbitrary >>= arbitrarySignedCertificate)
return $ CertificateChain (leaf:others)