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