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    ) where
13
14import Control.Applicative
15import Test.Tasty.QuickCheck
16import Data.ASN1.OID
17import Data.X509
18import Data.Hourglass
19import qualified Data.ByteString as B
20
21import PubKey
22
23arbitraryDN :: Gen DistinguishedName
24arbitraryDN = return $ DistinguishedName []
25
26instance Arbitrary Date where
27    arbitrary = do
28        y <- choose (1971, 2035)
29        m <- elements [ January .. December]
30        d <- choose (1, 30)
31        return $ normalizeDate $ Date y m d
32
33normalizeDate :: Date -> Date
34normalizeDate d = timeConvert (timeConvert d :: Elapsed)
35
36instance Arbitrary TimeOfDay where
37    arbitrary = do
38        h    <- choose (0, 23)
39        mi   <- choose (0, 59)
40        se   <- choose (0, 59)
41        nsec <- return 0
42        return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec
43
44instance Arbitrary DateTime where
45    arbitrary = DateTime <$> arbitrary <*> arbitrary
46
47maxSerial :: Integer
48maxSerial = 16777216
49
50arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate
51arbitraryCertificate usageFlags pubKey = do
52    serial    <- choose (0,maxSerial)
53    subjectdn <- arbitraryDN
54    validity  <- (,) <$> arbitrary <*> arbitrary
55    let sigalg = getSignatureALG pubKey
56    return $ Certificate
57            { certVersion      = 3
58            , certSerial       = serial
59            , certSignatureAlg = sigalg
60            , certIssuerDN     = issuerdn
61            , certSubjectDN    = subjectdn
62            , certValidity     = validity
63            , certPubKey       = pubKey
64            , certExtensions   = Extensions $ Just
65                [ extensionEncode True $ ExtKeyUsage usageFlags
66                ]
67            }
68  where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")]
69
70simpleCertificate :: PubKey -> Certificate
71simpleCertificate pubKey =
72    Certificate
73        { certVersion = 3
74        , certSerial = 0
75        , certSignatureAlg = getSignatureALG pubKey
76        , certIssuerDN     = simpleDN
77        , certSubjectDN    = simpleDN
78        , certValidity     = (time1, time2)
79        , certPubKey       = pubKey
80        , certExtensions   = Extensions $ Just
81                [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment]
82                ]
83        }
84  where time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0)
85        time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0)
86        simpleDN = DistinguishedName []
87
88simpleX509 :: PubKey -> SignedCertificate
89simpleX509 pubKey =
90    let cert = simpleCertificate pubKey
91        sig  = replicate 40 1
92        sigalg = getSignatureALG pubKey
93        (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert
94     in signedExact
95
96arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate
97arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage
98
99arbitraryX509WithKeyAndUsage :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate
100arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do
101    cert <- arbitraryCertificate usageFlags pubKey
102    sig  <- resize 40 $ listOf1 arbitrary
103    let sigalg = getSignatureALG pubKey
104    let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert
105    return signedExact
106
107arbitraryX509 :: Gen SignedCertificate
108arbitraryX509 = do
109    let (pubKey, privKey) = getGlobalRSAPair
110    arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey)
111
112arbitraryKeyUsage :: Gen [ExtKeyUsageFlag]
113arbitraryKeyUsage = sublistOf knownKeyUsage
114
115knownKeyUsage :: [ExtKeyUsageFlag]
116knownKeyUsage = [ KeyUsage_digitalSignature
117                , KeyUsage_keyEncipherment
118                , KeyUsage_keyAgreement
119                ]
120
121getSignatureALG :: PubKey -> SignatureALG
122getSignatureALG (PubKeyRSA      _) = SignatureALG HashSHA1      PubKeyALG_RSA
123getSignatureALG (PubKeyDSA      _) = SignatureALG HashSHA1      PubKeyALG_DSA
124getSignatureALG (PubKeyEC       _) = SignatureALG HashSHA256    PubKeyALG_EC
125getSignatureALG (PubKeyEd25519  _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519
126getSignatureALG (PubKeyEd448    _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448
127getSignatureALG pubKey             = error $ "getSignatureALG: unsupported public key: " ++ show pubKey
128