1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# OPTIONS_GHC -fno-warn-orphans #-}
4module Certificate
5    ( arbitraryX509
6    , arbitraryX509WithKey
7    , arbitraryX509WithKeyAndUsage
8    , arbitraryDN
9    , arbitraryKeyUsage
10    , simpleCertificate
11    , simpleX509
12    , toPubKeyEC
13    , toPrivKeyEC
14    ) where
15
16import Control.Applicative
17import Test.Tasty.QuickCheck
18import Data.ASN1.OID
19import Data.X509
20import Data.Hourglass
21import Crypto.Number.Serialize (i2ospOf_)
22import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
23import qualified Crypto.PubKey.ECC.Types as ECC
24import qualified Data.ByteString as B
25
26import PubKey
27
28arbitraryDN :: Gen DistinguishedName
29arbitraryDN = return $ DistinguishedName []
30
31instance Arbitrary Date where
32    arbitrary = do
33        y <- choose (1971, 2035)
34        m <- elements [ January .. December]
35        d <- choose (1, 30)
36        return $ normalizeDate $ Date y m d
37
38normalizeDate :: Date -> Date
39normalizeDate d = timeConvert (timeConvert d :: Elapsed)
40
41instance Arbitrary TimeOfDay where
42    arbitrary = do
43        h    <- choose (0, 23)
44        mi   <- choose (0, 59)
45        se   <- choose (0, 59)
46        nsec <- return 0
47        return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec
48
49instance Arbitrary DateTime where
50    arbitrary = DateTime <$> arbitrary <*> arbitrary
51
52maxSerial :: Integer
53maxSerial = 16777216
54
55arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate
56arbitraryCertificate usageFlags pubKey = do
57    serial    <- choose (0,maxSerial)
58    subjectdn <- arbitraryDN
59    validity  <- (,) <$> arbitrary <*> arbitrary
60    let sigalg = getSignatureALG pubKey
61    return $ Certificate
62            { certVersion      = 3
63            , certSerial       = serial
64            , certSignatureAlg = sigalg
65            , certIssuerDN     = issuerdn
66            , certSubjectDN    = subjectdn
67            , certValidity     = validity
68            , certPubKey       = pubKey
69            , certExtensions   = Extensions $ Just
70                [ extensionEncode True $ ExtKeyUsage usageFlags
71                ]
72            }
73  where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")]
74
75simpleCertificate :: PubKey -> Certificate
76simpleCertificate pubKey =
77    Certificate
78        { certVersion = 3
79        , certSerial = 0
80        , certSignatureAlg = getSignatureALG pubKey
81        , certIssuerDN     = simpleDN
82        , certSubjectDN    = simpleDN
83        , certValidity     = (time1, time2)
84        , certPubKey       = pubKey
85        , certExtensions   = Extensions $ Just
86                [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment]
87                ]
88        }
89  where time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0)
90        time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0)
91        simpleDN = DistinguishedName []
92
93simpleX509 :: PubKey -> SignedCertificate
94simpleX509 pubKey =
95    let cert = simpleCertificate pubKey
96        sig  = replicate 40 1
97        sigalg = getSignatureALG pubKey
98        (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert
99     in signedExact
100
101arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate
102arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage
103
104arbitraryX509WithKeyAndUsage :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate
105arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do
106    cert <- arbitraryCertificate usageFlags pubKey
107    sig  <- resize 40 $ listOf1 arbitrary
108    let sigalg = getSignatureALG pubKey
109    let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert
110    return signedExact
111
112arbitraryX509 :: Gen SignedCertificate
113arbitraryX509 = do
114    let (pubKey, privKey) = getGlobalRSAPair
115    arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey)
116
117arbitraryKeyUsage :: Gen [ExtKeyUsageFlag]
118arbitraryKeyUsage = sublistOf knownKeyUsage
119
120knownKeyUsage :: [ExtKeyUsageFlag]
121knownKeyUsage = [ KeyUsage_digitalSignature
122                , KeyUsage_keyEncipherment
123                , KeyUsage_keyAgreement
124                ]
125
126getSignatureALG :: PubKey -> SignatureALG
127getSignatureALG (PubKeyRSA      _) = SignatureALG HashSHA1      PubKeyALG_RSA
128getSignatureALG (PubKeyDSA      _) = SignatureALG HashSHA1      PubKeyALG_DSA
129getSignatureALG (PubKeyEC       _) = SignatureALG HashSHA256    PubKeyALG_EC
130getSignatureALG (PubKeyEd25519  _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519
131getSignatureALG (PubKeyEd448    _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448
132getSignatureALG pubKey             = error $ "getSignatureALG: unsupported public key: " ++ show pubKey
133
134toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey
135toPubKeyEC curveName key =
136    let ECC.Point x y = ECDSA.public_q key
137        pub   = SerializedPoint bs
138        bs    = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y)
139        bits  = ECC.curveSizeBits (ECC.getCurveByName curveName)
140        bytes = (bits + 7) `div` 8
141     in PubKeyEC (PubKeyEC_Named curveName pub)
142
143toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey
144toPrivKeyEC curveName key =
145    let priv = ECDSA.private_d key
146     in PrivKeyEC (PrivKeyEC_Named curveName priv)
147