1{-# LANGUAGE GADTs #-}
2-- | Types and functions used to build test certificates.
3module Certificate
4    (
5    -- * Hash algorithms
6      hashMD2
7    , hashMD5
8    , hashSHA1
9    , hashSHA224
10    , hashSHA256
11    , hashSHA384
12    , hashSHA512
13    -- * Key and signature utilities
14    , Alg(..)
15    , Keys
16    , generateKeys
17    -- * Certificate utilities
18    , Pair(..)
19    , mkDn
20    , mkExtension
21    , leafStdExts
22    -- * Certificate creation functions
23    , Auth(..)
24    , mkCertificate
25    , mkCA
26    , mkLeaf
27    ) where
28
29import Control.Applicative
30
31import Crypto.Hash.Algorithms
32import Crypto.Number.Serialize
33
34import qualified Crypto.PubKey.DSA        as DSA
35import qualified Crypto.PubKey.ECC.ECDSA  as ECDSA
36import qualified Crypto.PubKey.ECC.Generate as ECC
37import qualified Crypto.PubKey.ECC.Types  as ECC
38import qualified Crypto.PubKey.Ed25519    as Ed25519
39import qualified Crypto.PubKey.Ed448      as Ed448
40import qualified Crypto.PubKey.RSA        as RSA
41import qualified Crypto.PubKey.RSA.PKCS15 as RSA
42import qualified Crypto.PubKey.RSA.PSS    as PSS
43
44import qualified Data.ByteString as B
45
46import Data.ASN1.BinaryEncoding (DER(..))
47import Data.ASN1.Encoding
48import Data.ASN1.Types
49import Data.ByteArray (convert)
50import Data.Maybe (catMaybes)
51import Data.String (fromString)
52import Data.X509
53
54import Data.Hourglass
55
56
57-- Crypto utilities --
58
59-- | Hash algorithms supported in certificates.
60--
61-- This relates the typed hash algorithm @hash@ to the 'HashALG' value.
62data GHash hash = GHash { getHashALG :: HashALG, getHashAlgorithm :: hash }
63
64hashMD2    :: GHash MD2
65hashMD5    :: GHash MD5
66hashSHA1   :: GHash SHA1
67hashSHA224 :: GHash SHA224
68hashSHA256 :: GHash SHA256
69hashSHA384 :: GHash SHA384
70hashSHA512 :: GHash SHA512
71
72hashMD2    = GHash HashMD2    MD2
73hashMD5    = GHash HashMD5    MD5
74hashSHA1   = GHash HashSHA1   SHA1
75hashSHA224 = GHash HashSHA224 SHA224
76hashSHA256 = GHash HashSHA256 SHA256
77hashSHA384 = GHash HashSHA384 SHA384
78hashSHA512 = GHash HashSHA512 SHA512
79
80-- | Signature and hash algorithms instantiated with parameters.
81data Alg pub priv where
82    AlgRSA    :: (HashAlgorithm hash, RSA.HashAlgorithmASN1 hash)
83              => Int
84              -> GHash hash
85              -> Alg RSA.PublicKey RSA.PrivateKey
86
87    AlgRSAPSS :: HashAlgorithm hash
88              => Int
89              -> PSS.PSSParams hash B.ByteString B.ByteString
90              -> GHash hash
91              -> Alg RSA.PublicKey RSA.PrivateKey
92
93    AlgDSA    :: HashAlgorithm hash
94              => DSA.Params
95              -> GHash hash
96              -> Alg DSA.PublicKey DSA.PrivateKey
97
98    AlgEC     :: HashAlgorithm hash
99              => ECC.CurveName
100              -> GHash hash
101              -> Alg ECDSA.PublicKey ECDSA.PrivateKey
102
103    AlgEd25519 :: Alg Ed25519.PublicKey Ed25519.SecretKey
104
105    AlgEd448   :: Alg Ed448.PublicKey Ed448.SecretKey
106
107-- | Types of public and private keys used by a signature algorithm.
108type Keys pub priv = (Alg pub priv, pub, priv)
109
110-- | Generates random keys for a signature algorithm.
111generateKeys :: Alg pub priv -> IO (Keys pub priv)
112generateKeys alg@(AlgRSA bits      _) = generateRSAKeys alg bits
113generateKeys alg@(AlgRSAPSS bits _ _) = generateRSAKeys alg bits
114generateKeys alg@(AlgDSA params    _) = do
115    x <- DSA.generatePrivate params
116    let y = DSA.calculatePublic params x
117    return (alg, DSA.PublicKey params y, DSA.PrivateKey params x)
118generateKeys alg@(AlgEC name       _) = do
119    let curve = ECC.getCurveByName name
120    (pub, priv) <- ECC.generate curve
121    return (alg, pub, priv)
122generateKeys alg@AlgEd25519           = do
123    secret <- Ed25519.generateSecretKey
124    return (alg, Ed25519.toPublic secret, secret)
125generateKeys alg@AlgEd448             = do
126    secret <- Ed448.generateSecretKey
127    return (alg, Ed448.toPublic secret, secret)
128
129generateRSAKeys :: Alg RSA.PublicKey RSA.PrivateKey
130                -> Int
131                -> IO (Alg RSA.PublicKey RSA.PrivateKey, RSA.PublicKey, RSA.PrivateKey)
132generateRSAKeys alg bits = addAlg <$> RSA.generate size e
133  where
134    addAlg (pub, priv) = (alg, pub, priv)
135    size = bits `div` 8
136    e    = 3
137
138getPubKey :: Alg pub priv -> pub -> PubKey
139getPubKey (AlgRSA    _    _) key = PubKeyRSA key
140getPubKey (AlgRSAPSS _ _  _) key = PubKeyRSA key
141getPubKey (AlgDSA    _    _) key = PubKeyDSA key
142getPubKey (AlgEC     name _) key = PubKeyEC (PubKeyEC_Named name pub)
143  where
144    ECC.Point x y = ECDSA.public_q key
145    pub   = SerializedPoint bs
146    bs    = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y)
147    bits  = ECC.curveSizeBits (ECC.getCurveByName name)
148    bytes = (bits + 7) `div` 8
149getPubKey  AlgEd25519        key = PubKeyEd25519   key
150getPubKey  AlgEd448          key = PubKeyEd448     key
151
152getSignatureALG :: Alg pub priv -> SignatureALG
153getSignatureALG (AlgRSA    _   hash) = SignatureALG (getHashALG hash) PubKeyALG_RSA
154getSignatureALG (AlgRSAPSS _ _ hash) = SignatureALG (getHashALG hash) PubKeyALG_RSAPSS
155getSignatureALG (AlgDSA    _   hash) = SignatureALG (getHashALG hash) PubKeyALG_DSA
156getSignatureALG (AlgEC     _   hash) = SignatureALG (getHashALG hash) PubKeyALG_EC
157getSignatureALG  AlgEd25519          = SignatureALG_IntrinsicHash PubKeyALG_Ed25519
158getSignatureALG  AlgEd448            = SignatureALG_IntrinsicHash PubKeyALG_Ed448
159
160doSign :: Alg pub priv -> priv -> B.ByteString -> IO B.ByteString
161doSign (AlgRSA _ hash)        key msg = do
162    result <- RSA.signSafer (Just $ getHashAlgorithm hash) key msg
163    case result of
164        Left err      -> error ("doSign(AlgRSA): " ++ show err)
165        Right sigBits -> return sigBits
166doSign (AlgRSAPSS _ params _) key msg = do
167    result <- PSS.signSafer params key msg
168    case result of
169        Left err      -> error ("doSign(AlgRSAPSS): " ++ show err)
170        Right sigBits -> return sigBits
171doSign (AlgDSA _ hash)        key msg = do
172    sig <- DSA.sign key (getHashAlgorithm hash) msg
173    return $ encodeASN1' DER
174                 [ Start Sequence
175                 , IntVal (DSA.sign_r sig)
176                 , IntVal (DSA.sign_s sig)
177                 , End Sequence
178                 ]
179doSign (AlgEC _ hash)         key msg = do
180    sig <- ECDSA.sign key (getHashAlgorithm hash) msg
181    return $ encodeASN1' DER
182                 [ Start Sequence
183                 , IntVal (ECDSA.sign_r sig)
184                 , IntVal (ECDSA.sign_s sig)
185                 , End Sequence
186                 ]
187doSign  AlgEd25519            key msg =
188    return $ convert $ Ed25519.sign key (Ed25519.toPublic key) msg
189doSign  AlgEd448              key msg =
190    return $ convert $ Ed448.sign key (Ed448.toPublic key) msg
191
192
193-- Certificate utilities --
194
195-- | Holds together a certificate and its private key for convenience.
196--
197-- Contains also the crypto algorithm that both are issued from.  This is
198-- useful when signing another certificate.
199data Pair pub priv = Pair
200    { pairAlg        :: Alg pub priv
201    , pairSignedCert :: SignedCertificate
202    , pairKey        :: priv
203    }
204
205-- | Builds a DN with a single component.
206mkDn :: String -> DistinguishedName
207mkDn cn = DistinguishedName [(getObjectID DnCommonName, fromString cn)]
208
209-- | Used to build a certificate extension.
210mkExtension :: Extension a => Bool -> a -> ExtensionRaw
211mkExtension crit ext = ExtensionRaw (extOID ext) crit (extEncodeBs ext)
212
213-- | Default extensions in leaf certificates.
214leafStdExts :: [ExtensionRaw]
215leafStdExts = [ku, eku]
216  where
217    ku  = mkExtension False $ ExtKeyUsage
218               [ KeyUsage_digitalSignature , KeyUsage_keyEncipherment ]
219    eku = mkExtension False $ ExtExtendedKeyUsage
220               [ KeyUsagePurpose_ServerAuth , KeyUsagePurpose_ClientAuth ]
221
222
223-- Authority signing a certificate --
224--
225-- When the certificate is self-signed, issuer and subject are the same.  So
226-- they have identical signature algorithms.  The purpose of the GADT is to
227-- hold this constraint only in the self-signed case.
228
229-- | Authority signing a certificate, itself or another certificate.
230data Auth pubI privI pubS privS where
231    Self :: (pubI ~ pubS, privI ~ privS) => Auth pubI privI pubS privS
232    CA   ::              Pair pubI privI -> Auth pubI privI pubS privS
233
234foldAuth :: a
235         -> (Pair pubI privI -> a)
236         -> Auth pubI privI pubS privS
237         -> a
238foldAuth x _ Self   = x          -- no constraint used
239foldAuth _ f (CA p) = f p
240
241foldAuthPriv :: privS
242             -> (Pair pubI privI -> privI)
243             -> Auth pubI privI pubS privS
244             -> privI
245foldAuthPriv x _ Self   = x      -- uses constraint privI ~ privS
246foldAuthPriv _ f (CA p) = f p
247
248foldAuthPubPriv :: k pubS privS
249                -> (Pair pubI privI -> k pubI privI)
250                -> Auth pubI privI pubS privS
251                -> k pubI privI
252foldAuthPubPriv x _ Self   = x   -- uses both constraints
253foldAuthPubPriv _ f (CA p) = f p
254
255
256-- Certificate creation functions --
257
258-- | Builds a certificate using the supplied keys and signs it with an
259-- authority (itself or another certificate).
260mkCertificate :: Int                        -- ^ Certificate version
261              -> Integer                    -- ^ Serial number
262              -> DistinguishedName          -- ^ Subject DN
263              -> (DateTime, DateTime)       -- ^ Certificate validity period
264              -> [ExtensionRaw]             -- ^ Extensions to include
265              -> Auth pubI privI pubS privS -- ^ Authority signing the new certificate
266              -> Keys pubS privS            -- ^ Keys for the new certificate
267              -> IO (Pair pubS privS)       -- ^ The new certificate/key pair
268mkCertificate version serial dn validity exts auth (algS, pubKey, privKey) = do
269    signedCert <- objectToSignedExactF signatureFunction cert
270    return Pair { pairAlg        = algS
271                , pairSignedCert = signedCert
272                , pairKey        = privKey
273                }
274
275  where
276    pairCert = signedObject . getSigned . pairSignedCert
277
278    cert = Certificate
279        { certVersion      = version
280        , certSerial       = serial
281        , certSignatureAlg = signAlgI
282        , certIssuerDN     = issuerDN
283        , certValidity     = validity
284        , certSubjectDN    = dn
285        , certPubKey       = getPubKey algS pubKey
286        , certExtensions   = extensions
287        }
288
289    signingKey = foldAuthPriv     privKey pairKey auth
290    algI       = foldAuthPubPriv  algS    pairAlg auth
291
292    signAlgI   = getSignatureALG algI
293    issuerDN   = foldAuth dn (certSubjectDN . pairCert) auth
294    extensions = Extensions (if null exts then Nothing else Just exts)
295
296    signatureFunction objRaw = do
297        sigBits <- doSign algI signingKey objRaw
298        return (sigBits, signAlgI)
299
300-- | Builds a CA certificate using the supplied keys and signs it with an
301-- authority (itself or another certificate).
302mkCA :: Integer                    -- ^ Serial number
303     -> String                     -- ^ Common name
304     -> (DateTime, DateTime)       -- ^ CA validity period
305     -> Maybe ExtBasicConstraints  -- ^ CA basic constraints
306     -> Maybe ExtKeyUsage          -- ^ CA key usage
307     -> Auth pubI privI pubS privS -- ^ Authority signing the new certificate
308     -> Keys pubS privS            -- ^ Keys for the new certificate
309     -> IO (Pair pubS privS)       -- ^ The new CA certificate/key pair
310mkCA serial cn validity bc ku =
311    let exts = catMaybes [ mkExtension True <$> bc, mkExtension False <$> ku ]
312    in mkCertificate 2 serial (mkDn cn) validity exts
313
314-- | Builds a leaf certificate using the supplied keys and signs it with an
315-- authority (itself or another certificate).
316mkLeaf :: String                     -- ^ Common name
317       -> (DateTime, DateTime)       -- ^ Certificate validity period
318       -> Auth pubI privI pubS privS -- ^ Authority signing the new certificate
319       -> Keys pubS privS            -- ^ Keys for the new certificate
320       -> IO (Pair pubS privS)       -- ^ The new leaf certificate/key pair
321mkLeaf cn validity = mkCertificate 2 100 (mkDn cn) validity leafStdExts
322