diff --git a/Data/X509.hs b/Data/X509.hs new file mode 100644 --- /dev/null +++ b/Data/X509.hs @@ -0,0 +1,125 @@ +-- | +-- Module : Data.X509 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Read/Write X509 Certificate, CRL and their signed equivalents. +-- +-- Follows RFC5280 / RFC6818 +-- +module Data.X509 + ( + -- * Types + SignedCertificate + , SignedCRL + , Certificate(..) + , PubKey(..) + , PubKeyEC(..) + , SerializedPoint(..) + , PrivKey(..) + , PrivKeyEC(..) + , pubkeyToAlg + , privkeyToAlg + , module Data.X509.AlgorithmIdentifier + , module Data.X509.Ext + , module Data.X509.ExtensionRaw + + -- * Certificate Revocation List (CRL) + , module Data.X509.CRL + + -- * Naming + , DistinguishedName(..) + , DnElement(..) + , ASN1CharacterString(..) + , getDnElement + + -- * Certificate Chain + , module Data.X509.CertificateChain + + -- * Signed types and marshalling + , Signed(..) + , SignedExact + , getSigned + , getSignedData + , objectToSignedExact + , objectToSignedExactF + , encodeSignedObject + , decodeSignedObject + + -- * Parametrized Signed accessor + , getCertificate + , getCRL + , decodeSignedCertificate + , decodeSignedCRL + + -- * Hash distinguished names related function + , hashDN + , hashDN_old + ) where + +import Control.Arrow (second) + +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import qualified Data.ByteString as B +import qualified Data.ByteArray as BA + +import Data.X509.Cert +import Data.X509.Ext +import Data.X509.ExtensionRaw +import Data.X509.CRL +import Data.X509.CertificateChain +import Data.X509.DistinguishedName +import Data.X509.Signed +import Data.X509.PublicKey +import Data.X509.PrivateKey +import Data.X509.AlgorithmIdentifier + +import Crypto.Hash + +-- | A Signed Certificate +type SignedCertificate = SignedExact Certificate + +-- | A Signed CRL +type SignedCRL = SignedExact CRL + +-- | Get the Certificate associated to a SignedCertificate +getCertificate :: SignedCertificate -> Certificate +getCertificate = signedObject . getSigned + +-- | Get the CRL associated to a SignedCRL +getCRL :: SignedCRL -> CRL +getCRL = signedObject . getSigned + +-- | Try to decode a bytestring to a SignedCertificate +decodeSignedCertificate :: B.ByteString -> Either String SignedCertificate +decodeSignedCertificate = decodeSignedObject + +-- | Try to decode a bytestring to a SignedCRL +decodeSignedCRL :: B.ByteString -> Either String SignedCRL +decodeSignedCRL = decodeSignedObject + +-- | Make an OpenSSL style hash of distinguished name +-- +-- OpenSSL algorithm is odd, and has been replicated here somewhat. +-- only lower the case of ascii character. +hashDN :: DistinguishedName -> B.ByteString +hashDN = shorten . hashWith SHA1 . encodeASN1' DER . flip toASN1 [] . DistinguishedNameInner . dnLowerUTF8 + where dnLowerUTF8 (DistinguishedName l) = DistinguishedName $ map (second toLowerUTF8) l + toLowerUTF8 (ASN1CharacterString _ s) = ASN1CharacterString UTF8 (B.map asciiToLower s) + asciiToLower c + | c >= w8A && c <= w8Z = fromIntegral (fromIntegral c - fromEnum 'A' + fromEnum 'a') + | otherwise = c + w8A = fromIntegral $ fromEnum 'A' + w8Z = fromIntegral $ fromEnum 'Z' + +-- | Create an openssl style old hash of distinguished name +hashDN_old :: DistinguishedName -> B.ByteString +hashDN_old = shorten . hashWith MD5 . encodeASN1' DER . flip toASN1 [] + +shorten :: Digest a -> B.ByteString +shorten b = B.pack $ map i [3,2,1,0] + where i n = BA.index b n diff --git a/Data/X509/AlgorithmIdentifier.hs b/Data/X509/AlgorithmIdentifier.hs new file mode 100644 --- /dev/null +++ b/Data/X509/AlgorithmIdentifier.hs @@ -0,0 +1,120 @@ +-- | +-- Module : Data.X509.AlgorithmIdentifier +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Data.X509.AlgorithmIdentifier + ( HashALG(..) + , PubKeyALG(..) + , SignatureALG(..) + ) where + +import Data.ASN1.Types +import Data.List (find) + +-- | Hash Algorithm +data HashALG = + HashMD2 + | HashMD5 + | HashSHA1 + | HashSHA224 + | HashSHA256 + | HashSHA384 + | HashSHA512 + deriving (Show,Eq) + +-- | Public Key Algorithm +data PubKeyALG = + PubKeyALG_RSA -- ^ RSA Public Key algorithm + | PubKeyALG_RSAPSS -- ^ RSA PSS Key algorithm (RFC 3447) + | PubKeyALG_DSA -- ^ DSA Public Key algorithm + | PubKeyALG_EC -- ^ ECDSA & ECDH Public Key algorithm + | PubKeyALG_X25519 -- ^ ECDH 25519 key agreement + | PubKeyALG_X448 -- ^ ECDH 448 key agreement + | PubKeyALG_Ed25519 -- ^ EdDSA 25519 signature algorithm + | PubKeyALG_Ed448 -- ^ EdDSA 448 signature algorithm + | PubKeyALG_DH -- ^ Diffie Hellman Public Key algorithm + | PubKeyALG_Unknown OID -- ^ Unknown Public Key algorithm + deriving (Show,Eq) + +-- | Signature Algorithm, often composed of a public key algorithm and a hash +-- algorithm. For some signature algorithms the hash algorithm is intrinsic to +-- the public key algorithm and is not needed in the data type. +data SignatureALG = + SignatureALG HashALG PubKeyALG + | SignatureALG_IntrinsicHash PubKeyALG + | SignatureALG_Unknown OID + deriving (Show,Eq) + +instance OIDable PubKeyALG where + getObjectID PubKeyALG_RSA = [1,2,840,113549,1,1,1] + getObjectID PubKeyALG_RSAPSS = [1,2,840,113549,1,1,10] + getObjectID PubKeyALG_DSA = [1,2,840,10040,4,1] + getObjectID PubKeyALG_EC = [1,2,840,10045,2,1] + getObjectID PubKeyALG_X25519 = [1,3,101,110] + getObjectID PubKeyALG_X448 = [1,3,101,111] + getObjectID PubKeyALG_Ed25519 = [1,3,101,112] + getObjectID PubKeyALG_Ed448 = [1,3,101,113] + getObjectID PubKeyALG_DH = [1,2,840,10046,2,1] + getObjectID (PubKeyALG_Unknown oid) = oid + +sig_table :: [ (OID, SignatureALG) ] +sig_table = + [ ([1,2,840,113549,1,1,5], SignatureALG HashSHA1 PubKeyALG_RSA) + , ([1,2,840,113549,1,1,4], SignatureALG HashMD5 PubKeyALG_RSA) + , ([1,2,840,113549,1,1,2], SignatureALG HashMD2 PubKeyALG_RSA) + , ([1,2,840,113549,1,1,11], SignatureALG HashSHA256 PubKeyALG_RSA) + , ([1,2,840,113549,1,1,12], SignatureALG HashSHA384 PubKeyALG_RSA) + , ([1,2,840,113549,1,1,13], SignatureALG HashSHA512 PubKeyALG_RSA) + , ([1,2,840,113549,1,1,14], SignatureALG HashSHA224 PubKeyALG_RSA) + , ([1,2,840,10040,4,3], SignatureALG HashSHA1 PubKeyALG_DSA) + , ([1,2,840,10045,4,1], SignatureALG HashSHA1 PubKeyALG_EC) + , ([1,2,840,10045,4,3,1], SignatureALG HashSHA224 PubKeyALG_EC) + , ([1,2,840,10045,4,3,2], SignatureALG HashSHA256 PubKeyALG_EC) + , ([1,2,840,10045,4,3,3], SignatureALG HashSHA384 PubKeyALG_EC) + , ([1,2,840,10045,4,3,4], SignatureALG HashSHA512 PubKeyALG_EC) + , ([2,16,840,1,101,3,4,2,1], SignatureALG HashSHA256 PubKeyALG_RSAPSS) + , ([2,16,840,1,101,3,4,2,2], SignatureALG HashSHA384 PubKeyALG_RSAPSS) + , ([2,16,840,1,101,3,4,2,3], SignatureALG HashSHA512 PubKeyALG_RSAPSS) + , ([2,16,840,1,101,3,4,2,4], SignatureALG HashSHA224 PubKeyALG_RSAPSS) + , ([2,16,840,1,101,3,4,3,1], SignatureALG HashSHA224 PubKeyALG_DSA) + , ([2,16,840,1,101,3,4,3,2], SignatureALG HashSHA256 PubKeyALG_DSA) + , ([1,3,101,112], SignatureALG_IntrinsicHash PubKeyALG_Ed25519) + , ([1,3,101,113], SignatureALG_IntrinsicHash PubKeyALG_Ed448) + ] + +oidSig :: OID -> SignatureALG +oidSig oid = maybe (SignatureALG_Unknown oid) id $ lookup oid sig_table + +sigOID :: SignatureALG -> OID +sigOID (SignatureALG_Unknown oid) = oid +sigOID sig = maybe (error ("unknown OID for " ++ show sig)) fst $ find ((==) sig . snd) sig_table + +-- | PSS salt length. Always assume ``-sigopt rsa_pss_saltlen:-1`` +saltLen :: HashALG -> Integer +saltLen HashSHA256 = 32 +saltLen HashSHA384 = 48 +saltLen HashSHA512 = 64 +saltLen HashSHA224 = 28 +saltLen _ = error "toASN1: X509.SignatureAlg.HashAlg: Unknown hash" + +instance ASN1Object SignatureALG where + fromASN1 (Start Sequence:OID oid:Null:End Sequence:xs) = + case oidSig oid of + SignatureALG_IntrinsicHash _ -> + Left "fromASN1: X509.SignatureALG: EdDSA requires absent parameter" + signatureAlg -> Right (signatureAlg, xs) + fromASN1 (Start Sequence:OID oid:End Sequence:xs) = + Right (oidSig oid, xs) + fromASN1 (Start Sequence:OID [1,2,840,113549,1,1,10]:Start Sequence:Start _:Start Sequence:OID hash1:End Sequence:End _:Start _:Start Sequence:OID [1,2,840,113549,1,1,8]:Start Sequence:OID _hash2:End Sequence:End Sequence:End _:Start _: IntVal _iv: End _: End Sequence : End Sequence:xs) = + Right (oidSig hash1, xs) + fromASN1 (Start Sequence:OID [1,2,840,113549,1,1,10]:Start Sequence:Start _:Start Sequence:OID hash1:Null:End Sequence:End _:Start _:Start Sequence:OID [1,2,840,113549,1,1,8]:Start Sequence:OID _hash2:Null:End Sequence:End Sequence:End _:Start _: IntVal _iv: End _: End Sequence : End Sequence:xs) = + Right (oidSig hash1, xs) + fromASN1 _ = + Left "fromASN1: X509.SignatureALG: unknown format" + toASN1 (SignatureALG_Unknown oid) = \xs -> Start Sequence:OID oid:Null:End Sequence:xs + toASN1 signatureAlg@(SignatureALG hashAlg PubKeyALG_RSAPSS) = \xs -> Start Sequence:OID [1,2,840,113549,1,1,10]:Start Sequence:Start (Container Context 0):Start Sequence:OID (sigOID signatureAlg):End Sequence:End (Container Context 0):Start (Container Context 1): Start Sequence:OID [1,2,840,113549,1,1,8]:Start Sequence:OID (sigOID signatureAlg):End Sequence:End Sequence:End (Container Context 1):Start (Container Context 2):IntVal (saltLen hashAlg):End (Container Context 2):End Sequence:End Sequence:xs + toASN1 signatureAlg@(SignatureALG_IntrinsicHash _) = \xs -> Start Sequence:OID (sigOID signatureAlg):End Sequence:xs + toASN1 signatureAlg = \xs -> Start Sequence:OID (sigOID signatureAlg):Null:End Sequence:xs diff --git a/Data/X509/CRL.hs b/Data/X509/CRL.hs new file mode 100644 --- /dev/null +++ b/Data/X509/CRL.hs @@ -0,0 +1,119 @@ +-- | +-- Module : Data.X509.CRL +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Read and Write X509 Certificate Revocation List (CRL). +-- +-- follows RFC5280 / RFC6818. +-- +{-# LANGUAGE FlexibleContexts #-} + +module Data.X509.CRL + ( CRL(..) + , RevokedCertificate(..) + ) where + +import Control.Applicative + +import Data.Hourglass (DateTime, TimezoneOffset(..)) +import Data.ASN1.Types + +import Data.X509.DistinguishedName +import Data.X509.AlgorithmIdentifier +import Data.X509.ExtensionRaw +import Data.X509.Internal + +-- | Describe a Certificate revocation list +data CRL = CRL + { crlVersion :: Integer + , crlSignatureAlg :: SignatureALG + , crlIssuer :: DistinguishedName + , crlThisUpdate :: DateTime + , crlNextUpdate :: Maybe DateTime + , crlRevokedCertificates :: [RevokedCertificate] + , crlExtensions :: Extensions + } deriving (Show,Eq) + +-- | Describe a revoked certificate identifiable by serial number. +data RevokedCertificate = RevokedCertificate + { revokedSerialNumber :: Integer + , revokedDate :: DateTime + , revokedExtensions :: Extensions + } deriving (Show,Eq) + +instance ASN1Object CRL where + toASN1 crl = encodeCRL crl + fromASN1 = runParseASN1State parseCRL + +instance ASN1Object RevokedCertificate where + fromASN1 = runParseASN1State $ + onNextContainer Sequence $ + RevokedCertificate + <$> parseSerialNumber + <*> (getNext >>= toTime) + <*> getObject + where toTime (ASN1Time _ t _) = pure t + toTime _ = throwParseError "bad revocation date" + toASN1 (RevokedCertificate serial time crlEntryExtensions) = \xs -> + [ Start Sequence ] ++ + [ IntVal serial ] ++ + [ ASN1Time TimeGeneralized time (Just (TimezoneOffset 0)) ] ++ + toASN1 crlEntryExtensions [] ++ + [ End Sequence ] ++ + xs + +parseSerialNumber :: ParseASN1 Integer +parseSerialNumber = do + n <- getNext + case n of + IntVal v -> return v + _ -> throwParseError ("missing serial" ++ show n) + +parseCRL :: ParseASN1 CRL +parseCRL = do + CRL <$> (getNext >>= getVersion) + <*> getObject + <*> getObject + <*> (getNext >>= getThisUpdate) + <*> getNextUpdate + <*> parseRevokedCertificates + <*> parseCRLExtensions + where getVersion (IntVal v) = return $ fromIntegral v + getVersion _ = throwParseError "unexpected type for version" + + getThisUpdate (ASN1Time _ t1 _) = return t1 + getThisUpdate _ = throwParseError "bad this update format, expecting time" + + getNextUpdate = getNextMaybe timeOrNothing + + timeOrNothing (ASN1Time _ tnext _) = Just tnext + timeOrNothing _ = Nothing + +parseRevokedCertificates :: ParseASN1 [RevokedCertificate] +parseRevokedCertificates = + fmap (maybe [] id) $ onNextContainerMaybe Sequence $ getMany getObject + +parseCRLExtensions :: ParseASN1 Extensions +parseCRLExtensions = + fmap adapt $ onNextContainerMaybe (Container Context 0) $ getObject + where adapt (Just e) = e + adapt Nothing = Extensions Nothing + +encodeCRL :: CRL -> ASN1S +encodeCRL crl xs = + [IntVal $ crlVersion crl] ++ + toASN1 (crlSignatureAlg crl) [] ++ + toASN1 (crlIssuer crl) [] ++ + [ASN1Time TimeGeneralized (crlThisUpdate crl) (Just (TimezoneOffset 0))] ++ + (maybe [] (\t -> [ASN1Time TimeGeneralized t (Just (TimezoneOffset 0))]) (crlNextUpdate crl)) ++ + maybeRevoked (crlRevokedCertificates crl) ++ + maybeCrlExts (crlExtensions crl) ++ + xs + where + maybeRevoked [] = [] + maybeRevoked xs' = asn1Container Sequence $ concatMap (\e -> toASN1 e []) xs' + maybeCrlExts (Extensions Nothing) = [] + maybeCrlExts exts = asn1Container (Container Context 0) $ toASN1 exts [] diff --git a/Data/X509/Cert.hs b/Data/X509/Cert.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Cert.hs @@ -0,0 +1,123 @@ +-- | +-- Module : Data.X509.Cert +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- X.509 Certificate types and functions +-- +{-# LANGUAGE FlexibleContexts #-} + +module Data.X509.Cert (Certificate(..)) where + +import Data.ASN1.Types +import Control.Applicative ((<$>), (<*>)) +import Data.X509.Internal +import Data.X509.PublicKey +import Data.X509.AlgorithmIdentifier +import Data.X509.DistinguishedName +import Data.X509.ExtensionRaw +import Data.Hourglass + +data CertKeyUsage = + CertKeyUsageDigitalSignature + | CertKeyUsageNonRepudiation + | CertKeyUsageKeyEncipherment + | CertKeyUsageDataEncipherment + | CertKeyUsageKeyAgreement + | CertKeyUsageKeyCertSign + | CertKeyUsageCRLSign + | CertKeyUsageEncipherOnly + | CertKeyUsageDecipherOnly + deriving (Show, Eq) + +-- | X.509 Certificate type. +-- +-- This type doesn't include the signature, it's describe in the RFC +-- as tbsCertificate. +data Certificate = Certificate + { certVersion :: Int -- ^ Version + , certSerial :: Integer -- ^ Serial number + , certSignatureAlg :: SignatureALG -- ^ Signature algorithm + , certIssuerDN :: DistinguishedName -- ^ Issuer DN + , certValidity :: (DateTime, DateTime) -- ^ Validity period (UTC) + , certSubjectDN :: DistinguishedName -- ^ Subject DN + , certPubKey :: PubKey -- ^ Public key + , certExtensions :: Extensions -- ^ Extensions + } deriving (Show,Eq) + +instance ASN1Object Certificate where + toASN1 certificate = \xs -> encodeCertificateHeader certificate ++ xs + fromASN1 s = runParseASN1State parseCertificate s + +parseCertHeaderVersion :: ParseASN1 Int +parseCertHeaderVersion = + maybe 0 id <$> onNextContainerMaybe (Container Context 0) (getNext >>= getVer) + where getVer (IntVal v) = return $ fromIntegral v + getVer _ = throwParseError "unexpected type for version" + +parseCertHeaderSerial :: ParseASN1 Integer +parseCertHeaderSerial = do + n <- getNext + case n of + IntVal v -> return v + _ -> throwParseError ("missing serial" ++ show n) + +parseCertHeaderValidity :: ParseASN1 (DateTime, DateTime) +parseCertHeaderValidity = getNextContainer Sequence >>= toTimeBound + where toTimeBound [ ASN1Time _ t1 _, ASN1Time _ t2 _ ] = return (t1,t2) + toTimeBound _ = throwParseError "bad validity format" + +{- | parse header structure of a x509 certificate. the structure is the following: + Version + Serial Number + Algorithm ID + Issuer + Validity + Not Before + Not After + Subject + Subject Public Key Info + Public Key Algorithm + Subject Public Key + Issuer Unique Identifier (Optional) (>= 2) + Subject Unique Identifier (Optional) (>= 2) + Extensions (Optional) (>= v3) +-} + +parseExtensions :: ParseASN1 Extensions +parseExtensions = fmap adapt $ onNextContainerMaybe (Container Context 3) $ getObject + where adapt (Just e) = e + adapt Nothing = Extensions Nothing + +parseCertificate :: ParseASN1 Certificate +parseCertificate = + Certificate <$> parseCertHeaderVersion + <*> parseCertHeaderSerial + <*> getObject + <*> getObject + <*> parseCertHeaderValidity + <*> getObject + <*> getObject + <*> parseExtensions + +encodeCertificateHeader :: Certificate -> [ASN1] +encodeCertificateHeader cert = + eVer ++ eSerial ++ eAlgId ++ eIssuer ++ eValidity ++ eSubject ++ epkinfo ++ eexts + where eVer = asn1Container (Container Context 0) [IntVal (fromIntegral $ certVersion cert)] + eSerial = [IntVal $ certSerial cert] + eAlgId = toASN1 (certSignatureAlg cert) [] + eIssuer = toASN1 (certIssuerDN cert) [] + (t1, t2) = certValidity cert + eValidity = asn1Container Sequence [ASN1Time (timeType t1) t1 (Just (TimezoneOffset 0)) + ,ASN1Time (timeType t2) t2 (Just (TimezoneOffset 0))] + eSubject = toASN1 (certSubjectDN cert) [] + epkinfo = toASN1 (certPubKey cert) [] + eexts = case certExtensions cert of + Extensions Nothing -> [] + exts -> asn1Container (Container Context 3) $ toASN1 exts [] + timeType t = + if t >= timeConvert (Date 2050 January 1) + then TimeGeneralized + else TimeUTC diff --git a/Data/X509/CertificateChain.hs b/Data/X509/CertificateChain.hs new file mode 100644 --- /dev/null +++ b/Data/X509/CertificateChain.hs @@ -0,0 +1,42 @@ +-- | +-- Module : Data.X509.CertificateChain +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Data.X509.CertificateChain + ( CertificateChain(..) + , CertificateChainRaw(..) + -- * marshall between CertificateChain and CertificateChainRaw + , decodeCertificateChain + , encodeCertificateChain + ) where + +import Data.X509.Cert (Certificate) +import Data.X509.Signed (SignedExact, decodeSignedObject, encodeSignedObject) +import Data.ByteString (ByteString) + +-- | A chain of X.509 certificates in exact form. +newtype CertificateChain = CertificateChain [SignedExact Certificate] + deriving (Show,Eq) + +-- | Represent a chain of X.509 certificates in bytestring form. +newtype CertificateChainRaw = CertificateChainRaw [ByteString] + deriving (Show,Eq) + +-- | Decode a CertificateChainRaw into a CertificateChain if every +-- raw certificate are decoded correctly, otherwise return the index of the +-- failed certificate and the error associated. +decodeCertificateChain :: CertificateChainRaw -> Either (Int, String) CertificateChain +decodeCertificateChain (CertificateChainRaw l) = + either Left (Right . CertificateChain) $ loop 0 l + where loop _ [] = Right [] + loop i (r:rs) = case decodeSignedObject r of + Left err -> Left (i, err) + Right o -> either Left (Right . (o :)) $ loop (i+1) rs + +-- | Convert a CertificateChain into a CertificateChainRaw +encodeCertificateChain :: CertificateChain -> CertificateChainRaw +encodeCertificateChain (CertificateChain chain) = + CertificateChainRaw $ map encodeSignedObject chain diff --git a/Data/X509/DistinguishedName.hs b/Data/X509/DistinguishedName.hs new file mode 100644 --- /dev/null +++ b/Data/X509/DistinguishedName.hs @@ -0,0 +1,97 @@ +-- | +-- Module : Data.X509.DistinguishedName +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- X.509 Distinguished names types and functions + +{-# LANGUAGE CPP #-} +module Data.X509.DistinguishedName + ( DistinguishedName(..) + , DistinguishedNameInner(..) + , ASN1CharacterString(..) + -- Distinguished Name Elements + , DnElement(..) + , getDnElement + ) where + +import Control.Applicative +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +#else +import Data.Monoid +#endif +import Data.ASN1.Types +import Data.X509.Internal + +-- | A list of OID and strings. +newtype DistinguishedName = DistinguishedName { getDistinguishedElements :: [(OID, ASN1CharacterString)] } + deriving (Show,Eq,Ord) + +-- | Elements commonly available in a 'DistinguishedName' structure +data DnElement = + DnCommonName -- ^ CN + | DnCountry -- ^ Country + | DnOrganization -- ^ O + | DnOrganizationUnit -- ^ OU + | DnEmailAddress -- ^ Email Address (legacy) + deriving (Show,Eq) + +instance OIDable DnElement where + getObjectID DnCommonName = [2,5,4,3] + getObjectID DnCountry = [2,5,4,6] + getObjectID DnOrganization = [2,5,4,10] + getObjectID DnOrganizationUnit = [2,5,4,11] + getObjectID DnEmailAddress = [1,2,840,113549,1,9,1] + +-- | Try to get a specific element in a 'DistinguishedName' structure +getDnElement :: DnElement -> DistinguishedName -> Maybe ASN1CharacterString +getDnElement element (DistinguishedName els) = lookup (getObjectID element) els + +-- | Only use to encode a DistinguishedName without including it in a +-- Sequence +newtype DistinguishedNameInner = DistinguishedNameInner DistinguishedName + deriving (Show,Eq) + +#if MIN_VERSION_base(4,9,0) +instance Semigroup DistinguishedName where + DistinguishedName l1 <> DistinguishedName l2 = DistinguishedName (l1++l2) +#endif + +instance Monoid DistinguishedName where + mempty = DistinguishedName [] +#if !(MIN_VERSION_base(4,11,0)) + mappend (DistinguishedName l1) (DistinguishedName l2) = DistinguishedName (l1++l2) +#endif + +instance ASN1Object DistinguishedName where + toASN1 dn = \xs -> encodeDN dn ++ xs + fromASN1 = runParseASN1State parseDN + +-- FIXME parseDNInner in fromASN1 is probably wrong as we don't have a container +-- and thus hasNext should be replaced by a isFinished clause. +instance ASN1Object DistinguishedNameInner where + toASN1 (DistinguishedNameInner dn) = \xs -> encodeDNinner dn ++ xs + fromASN1 = runParseASN1State (DistinguishedNameInner . DistinguishedName <$> parseDNInner) + +parseDN :: ParseASN1 DistinguishedName +parseDN = DistinguishedName <$> onNextContainer Sequence parseDNInner + +parseDNInner :: ParseASN1 [(OID, ASN1CharacterString)] +parseDNInner = concat `fmap` getMany parseOneDN + +parseOneDN :: ParseASN1 [(OID, ASN1CharacterString)] +parseOneDN = onNextContainer Set $ getMany $ do + s <- getNextContainer Sequence + case s of + [OID oid, ASN1String cs] -> return (oid, cs) + _ -> throwParseError ("expecting [OID,String] got " ++ show s) + +encodeDNinner :: DistinguishedName -> [ASN1] +encodeDNinner (DistinguishedName dn) = concatMap dnSet dn + where dnSet (oid, cs) = asn1Container Set $ asn1Container Sequence [OID oid, ASN1String cs] + +encodeDN :: DistinguishedName -> [ASN1] +encodeDN dn = asn1Container Sequence $ encodeDNinner dn diff --git a/Data/X509/EC.hs b/Data/X509/EC.hs new file mode 100644 --- /dev/null +++ b/Data/X509/EC.hs @@ -0,0 +1,126 @@ +-- | +-- Module : Data.X509.EC +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Utilities related to Elliptic Curve certificates and keys. +-- +module Data.X509.EC + ( + unserializePoint + , ecPubKeyCurve + , ecPubKeyCurveName + , ecPrivKeyCurve + , ecPrivKeyCurveName + , lookupCurveNameByOID + ) where + +import Data.ASN1.OID +import Data.List (find) + +import Data.X509.OID +import Data.X509.PublicKey +import Data.X509.PrivateKey + +import qualified Crypto.PubKey.ECC.Prim as ECC +import qualified Crypto.PubKey.ECC.Types as ECC +import Crypto.Number.Serialize (os2ip) + +import qualified Data.ByteString as B + +-- | Read an EC point from a serialized format and make sure the point is +-- valid for the specified curve. +unserializePoint :: ECC.Curve -> SerializedPoint -> Maybe ECC.Point +unserializePoint curve (SerializedPoint bs) = + case B.uncons bs of + Nothing -> Nothing + Just (ptFormat, input) -> + case ptFormat of + 4 -> if B.length input /= 2 * bytes + then Nothing + else + let (x, y) = B.splitAt bytes input + p = ECC.Point (os2ip x) (os2ip y) + in if ECC.isPointValid curve p + then Just p + else Nothing + -- 2 and 3 for compressed format. + _ -> Nothing + where bits = ECC.curveSizeBits curve + bytes = (bits + 7) `div` 8 + +-- | Return the curve associated to an EC Public Key. This does not check +-- if a curve in explicit format is valid: if the input is not trusted one +-- should consider 'ecPubKeyCurveName' instead. +ecPubKeyCurve :: PubKeyEC -> Maybe ECC.Curve +ecPubKeyCurve (PubKeyEC_Named name _) = Just $ ECC.getCurveByName name +ecPubKeyCurve pub@PubKeyEC_Prime{} = + fmap buildCurve $ + unserializePoint (buildCurve undefined) (pubkeyEC_generator pub) + where + prime = pubkeyEC_prime pub + buildCurve g = + let cc = ECC.CurveCommon + { ECC.ecc_a = pubkeyEC_a pub + , ECC.ecc_b = pubkeyEC_b pub + , ECC.ecc_g = g + , ECC.ecc_n = pubkeyEC_order pub + , ECC.ecc_h = pubkeyEC_cofactor pub + } + in ECC.CurveFP (ECC.CurvePrime prime cc) + +-- | Return the name of a standard curve associated to an EC Public Key +ecPubKeyCurveName :: PubKeyEC -> Maybe ECC.CurveName +ecPubKeyCurveName (PubKeyEC_Named name _) = Just name +ecPubKeyCurveName pub@PubKeyEC_Prime{} = + find matchPrimeCurve $ enumFrom $ toEnum 0 + where + matchPrimeCurve c = + case ECC.getCurveByName c of + ECC.CurveFP (ECC.CurvePrime p cc) -> + ECC.ecc_a cc == pubkeyEC_a pub && + ECC.ecc_b cc == pubkeyEC_b pub && + ECC.ecc_n cc == pubkeyEC_order pub && + p == pubkeyEC_prime pub + _ -> False + +-- | Return the EC curve associated to an EC Private Key. This does not check +-- if a curve in explicit format is valid: if the input is not trusted one +-- should consider 'ecPrivKeyCurveName' instead. +ecPrivKeyCurve :: PrivKeyEC -> Maybe ECC.Curve +ecPrivKeyCurve (PrivKeyEC_Named name _) = Just $ ECC.getCurveByName name +ecPrivKeyCurve priv@PrivKeyEC_Prime{} = + fmap buildCurve $ + unserializePoint (buildCurve undefined) (privkeyEC_generator priv) + where + prime = privkeyEC_prime priv + buildCurve g = + let cc = ECC.CurveCommon + { ECC.ecc_a = privkeyEC_a priv + , ECC.ecc_b = privkeyEC_b priv + , ECC.ecc_g = g + , ECC.ecc_n = privkeyEC_order priv + , ECC.ecc_h = privkeyEC_cofactor priv + } + in ECC.CurveFP (ECC.CurvePrime prime cc) + +-- | Return the name of a standard curve associated to an EC Private Key +ecPrivKeyCurveName :: PrivKeyEC -> Maybe ECC.CurveName +ecPrivKeyCurveName (PrivKeyEC_Named name _) = Just name +ecPrivKeyCurveName priv@PrivKeyEC_Prime{} = + find matchPrimeCurve $ enumFrom $ toEnum 0 + where + matchPrimeCurve c = + case ECC.getCurveByName c of + ECC.CurveFP (ECC.CurvePrime p cc) -> + ECC.ecc_a cc == privkeyEC_a priv && + ECC.ecc_b cc == privkeyEC_b priv && + ECC.ecc_n cc == privkeyEC_order priv && + p == privkeyEC_prime priv + _ -> False + +-- | Return the curve name associated to an OID +lookupCurveNameByOID :: OID -> Maybe ECC.CurveName +lookupCurveNameByOID = lookupByOID curvesOIDTable diff --git a/Data/X509/Ext.hs b/Data/X509/Ext.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Ext.hs @@ -0,0 +1,350 @@ +-- | +-- Module : Data.X509.Ext +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- extension processing module. +-- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.X509.Ext + ( Extension(..) + -- * Common extension usually found in x509v3 + , ExtBasicConstraints(..) + , ExtKeyUsage(..) + , ExtKeyUsageFlag(..) + , ExtExtendedKeyUsage(..) + , ExtKeyUsagePurpose(..) + , ExtSubjectKeyId(..) + , ExtSubjectAltName(..) + , ExtAuthorityKeyId(..) + , ExtCrlDistributionPoints(..) + , ExtNetscapeComment(..) + , AltName(..) + , DistributionPoint(..) + , ReasonFlag(..) + -- * Accessor turning extension into a specific one + , extensionGet + , extensionGetE + , extensionDecode + , extensionEncode + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.ASN1.Types +import Data.ASN1.Parse +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import Data.ASN1.BitArray +import Data.Proxy +import Data.List (find) +import Data.X509.ExtensionRaw +import Data.X509.DistinguishedName +import Control.Applicative +import Control.Monad + +-- | key usage flag that is found in the key usage extension field. +data ExtKeyUsageFlag = + KeyUsage_digitalSignature -- (0) + | KeyUsage_nonRepudiation -- (1) recent X.509 ver have renamed this bit to contentCommitment + | KeyUsage_keyEncipherment -- (2) + | KeyUsage_dataEncipherment -- (3) + | KeyUsage_keyAgreement -- (4) + | KeyUsage_keyCertSign -- (5) + | KeyUsage_cRLSign -- (6) + | KeyUsage_encipherOnly -- (7) + | KeyUsage_decipherOnly -- (8) + deriving (Show,Eq,Ord,Enum) + +{- +-- RFC 5280 +oidDistributionPoints, oidPolicies, oidPoliciesMapping :: OID +oidPolicies = [2,5,29,32] +oidPoliciesMapping = [2,5,29,33] +-} + +-- | Extension class. +-- +-- each extension have a unique OID associated, and a way +-- to encode and decode an ASN1 stream. +-- +-- Errata: turns out, the content is not necessarily ASN1, +-- it could be data that is only parsable by the extension +-- e.g. raw ascii string. Add method to parse and encode with +-- ByteString +class Extension a where + extOID :: a -> OID + extHasNestedASN1 :: Proxy a -> Bool + extEncode :: a -> [ASN1] + extDecode :: [ASN1] -> Either String a + + extDecodeBs :: B.ByteString -> Either String a + extDecodeBs = (either (Left . show) Right . decodeASN1' BER) >=> extDecode + + extEncodeBs :: a -> B.ByteString + extEncodeBs = encodeASN1' DER . extEncode + + +-- | Get a specific extension from a lists of raw extensions +extensionGet :: Extension a => Extensions -> Maybe a +extensionGet (Extensions Nothing) = Nothing +extensionGet (Extensions (Just l)) = findExt l + where findExt [] = Nothing + findExt (x:xs) = case extensionDecode x of + Just (Right e) -> Just e + _ -> findExt xs + +-- | Get a specific extension from a lists of raw extensions +extensionGetE :: Extension a => Extensions -> Maybe (Either String a) +extensionGetE (Extensions Nothing) = Nothing +extensionGetE (Extensions (Just l)) = findExt l + where findExt [] = Nothing + findExt (x:xs) = case extensionDecode x of + Just r -> Just r + _ -> findExt xs + +-- | Try to decode an ExtensionRaw. +-- +-- If this function return: +-- * Nothing, the OID doesn't match +-- * Just Left, the OID matched, but the extension couldn't be decoded +-- * Just Right, the OID matched, and the extension has been succesfully decoded +extensionDecode :: forall a . Extension a => ExtensionRaw -> Maybe (Either String a) +extensionDecode er@(ExtensionRaw oid _ content) + | extOID (undefined :: a) /= oid = Nothing + | extHasNestedASN1 (Proxy :: Proxy a) = Just (tryExtRawASN1 er >>= extDecode) + | otherwise = Just (extDecodeBs content) + +-- | Encode an Extension to extensionRaw +extensionEncode :: forall a . Extension a => Bool -> a -> ExtensionRaw +extensionEncode critical ext + | extHasNestedASN1 (Proxy :: Proxy a) = ExtensionRaw (extOID ext) critical (encodeASN1' DER $ extEncode ext) + | otherwise = ExtensionRaw (extOID ext) critical (extEncodeBs ext) + +-- | Basic Constraints +data ExtBasicConstraints = ExtBasicConstraints Bool (Maybe Integer) + deriving (Show,Eq) + +instance Extension ExtBasicConstraints where + extOID = const [2,5,29,19] + extHasNestedASN1 = const True + extEncode (ExtBasicConstraints b Nothing) = [Start Sequence,Boolean b,End Sequence] + extEncode (ExtBasicConstraints b (Just i)) = [Start Sequence,Boolean b,IntVal i,End Sequence] + + extDecode [Start Sequence,Boolean b,IntVal v,End Sequence] + | v >= 0 = Right (ExtBasicConstraints b (Just v)) + | otherwise = Left "invalid pathlen" + extDecode [Start Sequence,Boolean b,End Sequence] = Right (ExtBasicConstraints b Nothing) + extDecode [Start Sequence,End Sequence] = Right (ExtBasicConstraints False Nothing) + extDecode _ = Left "unknown sequence" + +-- | Describe key usage +data ExtKeyUsage = ExtKeyUsage [ExtKeyUsageFlag] + deriving (Show,Eq) + +instance Extension ExtKeyUsage where + extOID = const [2,5,29,15] + extHasNestedASN1 = const True + extEncode (ExtKeyUsage flags) = [BitString $ flagsToBits flags] + extDecode [BitString bits] = Right $ ExtKeyUsage $ bitsToFlags bits + extDecode _ = Left "unknown sequence" + +-- | Key usage purposes for the ExtendedKeyUsage extension +data ExtKeyUsagePurpose = + KeyUsagePurpose_ServerAuth + | KeyUsagePurpose_ClientAuth + | KeyUsagePurpose_CodeSigning + | KeyUsagePurpose_EmailProtection + | KeyUsagePurpose_TimeStamping + | KeyUsagePurpose_OCSPSigning + | KeyUsagePurpose_Unknown OID + deriving (Show,Eq,Ord) + +extKeyUsagePurposedOID :: [(OID, ExtKeyUsagePurpose)] +extKeyUsagePurposedOID = + [(keyUsagePurposePrefix 1, KeyUsagePurpose_ServerAuth) + ,(keyUsagePurposePrefix 2, KeyUsagePurpose_ClientAuth) + ,(keyUsagePurposePrefix 3, KeyUsagePurpose_CodeSigning) + ,(keyUsagePurposePrefix 4, KeyUsagePurpose_EmailProtection) + ,(keyUsagePurposePrefix 8, KeyUsagePurpose_TimeStamping) + ,(keyUsagePurposePrefix 9, KeyUsagePurpose_OCSPSigning)] + where keyUsagePurposePrefix r = [1,3,6,1,5,5,7,3,r] + +-- | Extended key usage extension +data ExtExtendedKeyUsage = ExtExtendedKeyUsage [ExtKeyUsagePurpose] + deriving (Show,Eq) + +instance Extension ExtExtendedKeyUsage where + extOID = const [2,5,29,37] + extHasNestedASN1 = const True + extEncode (ExtExtendedKeyUsage purposes) = + [Start Sequence] ++ map (OID . lookupRev) purposes ++ [End Sequence] + where lookupRev (KeyUsagePurpose_Unknown oid) = oid + lookupRev kup = maybe (error "unknown key usage purpose") fst $ find ((==) kup . snd) extKeyUsagePurposedOID + extDecode l = ExtExtendedKeyUsage `fmap` (flip runParseASN1 l $ onNextContainer Sequence $ getMany $ do + n <- getNext + case n of + OID o -> return $ maybe (KeyUsagePurpose_Unknown o) id $ lookup o extKeyUsagePurposedOID + _ -> error "invalid content in extended key usage") + +-- | Provide a way to identify a public key by a short hash. +data ExtSubjectKeyId = ExtSubjectKeyId B.ByteString + deriving (Show,Eq) + +instance Extension ExtSubjectKeyId where + extOID = const [2,5,29,14] + extHasNestedASN1 = const True + extEncode (ExtSubjectKeyId o) = [OctetString o] + extDecode [OctetString o] = Right $ ExtSubjectKeyId o + extDecode _ = Left "unknown sequence" + +-- | Different naming scheme use by the extension. +-- +-- Not all name types are available, missing: +-- otherName +-- x400Address +-- directoryName +-- ediPartyName +-- registeredID +-- +data AltName = + AltNameRFC822 String + | AltNameDNS String + | AltNameURI String + | AltNameIP B.ByteString + | AltNameXMPP String + | AltNameDNSSRV String + deriving (Show,Eq,Ord) + +-- | Provide a way to supply alternate name that can be +-- used for matching host name. +data ExtSubjectAltName = ExtSubjectAltName [AltName] + deriving (Show,Eq,Ord) + +instance Extension ExtSubjectAltName where + extOID = const [2,5,29,17] + extHasNestedASN1 = const True + extEncode (ExtSubjectAltName names) = encodeGeneralNames names + extDecode l = runParseASN1 (ExtSubjectAltName <$> parseGeneralNames) l + +-- | Provide a mean to identify the public key corresponding to the private key +-- used to signed a certificate. +data ExtAuthorityKeyId = ExtAuthorityKeyId B.ByteString + deriving (Show,Eq) + +instance Extension ExtAuthorityKeyId where + extOID _ = [2,5,29,35] + extHasNestedASN1 = const True + extEncode (ExtAuthorityKeyId keyid) = + [Start Sequence,Other Context 0 keyid,End Sequence] + extDecode [Start Sequence,Other Context 0 keyid,End Sequence] = + Right $ ExtAuthorityKeyId keyid + extDecode _ = Left "unknown sequence" + +-- | Identify how CRL information is obtained +data ExtCrlDistributionPoints = ExtCrlDistributionPoints [DistributionPoint] + deriving (Show,Eq) + +-- | Reason flag for the CRL +data ReasonFlag = + Reason_Unused + | Reason_KeyCompromise + | Reason_CACompromise + | Reason_AffiliationChanged + | Reason_Superseded + | Reason_CessationOfOperation + | Reason_CertificateHold + | Reason_PrivilegeWithdrawn + | Reason_AACompromise + deriving (Show,Eq,Ord,Enum) + +-- | Distribution point as either some GeneralNames or a DN +data DistributionPoint = + DistributionPointFullName [AltName] + | DistributionNameRelative DistinguishedName + deriving (Show,Eq) + +instance Extension ExtCrlDistributionPoints where + extOID _ = [2,5,29,31] + extHasNestedASN1 = const True + extEncode = error "extEncode ExtCrlDistributionPoints unimplemented" + extDecode = error "extDecode ExtCrlDistributionPoints unimplemented" + --extEncode (ExtCrlDistributionPoints ) + +parseGeneralNames :: ParseASN1 [AltName] +parseGeneralNames = onNextContainer Sequence $ getMany getAddr + where + getAddr = do + m <- onNextContainerMaybe (Container Context 0) getComposedAddr + case m of + Nothing -> getSimpleAddr + Just r -> return r + getComposedAddr = do + n <- getNext + case n of + OID [1,3,6,1,5,5,7,8,5] -> do -- xmpp addr + c <- getNextContainerMaybe (Container Context 0) + case c of + Just [ASN1String cs] -> + case asn1CharacterToString cs of + Nothing -> throwParseError ("GeneralNames: invalid string for XMPP Addr") + Just s -> return $ AltNameXMPP s + _ -> throwParseError ("GeneralNames: expecting string for XMPP Addr got: " ++ show c) + OID [1,3,6,1,5,5,7,8,7] -> do -- DNSSRV addr + c <- getNextContainerMaybe (Container Context 0) + case c of + Just [ASN1String cs] -> + case asn1CharacterToString cs of + Nothing -> throwParseError ("GeneralNames: invalid string for DNSSrv Addr") + Just s -> return $ AltNameDNSSRV s + _ -> throwParseError ("GeneralNames: expecting string for DNSSRV Addr got: " ++ show c) + OID unknown -> throwParseError ("GeneralNames: unknown OID " ++ show unknown) + _ -> throwParseError ("GeneralNames: expecting OID but got " ++ show n) + + getSimpleAddr = do + n <- getNext + case n of + (Other Context 1 b) -> return $ AltNameRFC822 $ BC.unpack b + (Other Context 2 b) -> return $ AltNameDNS $ BC.unpack b + (Other Context 6 b) -> return $ AltNameURI $ BC.unpack b + (Other Context 7 b) -> return $ AltNameIP b + _ -> throwParseError ("GeneralNames: not coping with unknown stream " ++ show n) + +encodeGeneralNames :: [AltName] -> [ASN1] +encodeGeneralNames names = + [Start Sequence] + ++ concatMap encodeAltName names + ++ [End Sequence] + where encodeAltName (AltNameRFC822 n) = [Other Context 1 $ BC.pack n] + encodeAltName (AltNameDNS n) = [Other Context 2 $ BC.pack n] + encodeAltName (AltNameURI n) = [Other Context 6 $ BC.pack n] + encodeAltName (AltNameIP n) = [Other Context 7 $ n] + encodeAltName (AltNameXMPP n) = [Start (Container Context 0),OID[1,3,6,1,5,5,7,8,5] + ,Start (Container Context 0), ASN1String $ asn1CharacterString UTF8 n, End (Container Context 0) + ,End (Container Context 0)] + encodeAltName (AltNameDNSSRV n) = [Start (Container Context 0),OID[1,3,6,1,5,5,7,8,5] + ,Start (Container Context 0), ASN1String $ asn1CharacterString UTF8 n, End (Container Context 0) + ,End (Container Context 0)] + +bitsToFlags :: Enum a => BitArray -> [a] +bitsToFlags bits = concat $ flip map [0..(bitArrayLength bits-1)] $ \i -> do + let isSet = bitArrayGetBit bits i + if isSet then [toEnum $ fromIntegral i] else [] + +flagsToBits :: Enum a => [a] -> BitArray +flagsToBits flags = foldl bitArraySetBit bitArrayEmpty $ map (fromIntegral . fromEnum) flags + where bitArrayEmpty = toBitArray (B.pack [0,0]) 7 + +data ExtNetscapeComment = ExtNetscapeComment B.ByteString + deriving (Show,Eq) + +instance Extension ExtNetscapeComment where + extOID _ = [2,16,840,1,113730,1,13] + extHasNestedASN1 = const False + extEncode = error "Extension: Netscape Comment do not contain nested ASN1" + extDecode = error "Extension: Netscape Comment do not contain nested ASN1" + extEncodeBs (ExtNetscapeComment b) = b + extDecodeBs = Right . ExtNetscapeComment diff --git a/Data/X509/ExtensionRaw.hs b/Data/X509/ExtensionRaw.hs new file mode 100644 --- /dev/null +++ b/Data/X509/ExtensionRaw.hs @@ -0,0 +1,64 @@ +-- | +-- Module : Data.X509.ExtensionRaw +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- extension marshalling +-- +module Data.X509.ExtensionRaw + ( ExtensionRaw(..) + , tryExtRawASN1 + , extRawASN1 + , Extensions(..) + ) where + +import Control.Applicative +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import Data.X509.Internal +import qualified Data.ByteString as B + +-- | An undecoded extension +data ExtensionRaw = ExtensionRaw + { extRawOID :: OID -- ^ OID of this extension + , extRawCritical :: Bool -- ^ if this extension is critical + , extRawContent :: B.ByteString -- ^ undecoded content + } deriving (Show,Eq) + +tryExtRawASN1 :: ExtensionRaw -> Either String [ASN1] +tryExtRawASN1 (ExtensionRaw oid _ content) = + case decodeASN1' BER content of + Left err -> Left $ "fromASN1: X509.ExtensionRaw: OID=" ++ show oid ++ ": cannot decode data: " ++ show err + Right r -> Right r + +extRawASN1 :: ExtensionRaw -> [ASN1] +extRawASN1 extRaw = either error id $ tryExtRawASN1 extRaw +{-# DEPRECATED extRawASN1 "use tryExtRawASN1 instead" #-} + +-- | a Set of 'ExtensionRaw' +newtype Extensions = Extensions (Maybe [ExtensionRaw]) + deriving (Show,Eq) + +instance ASN1Object Extensions where + toASN1 (Extensions Nothing) = \xs -> xs + toASN1 (Extensions (Just exts)) = \xs -> + asn1Container Sequence (concatMap encodeExt exts) ++ xs + fromASN1 s = runParseASN1State (Extensions <$> parseExtensions) s + where parseExtensions = onNextContainerMaybe Sequence (getMany getObject) + +instance ASN1Object ExtensionRaw where + toASN1 extraw = \xs -> encodeExt extraw ++ xs + fromASN1 (Start Sequence:OID oid:xs) = + case xs of + Boolean b:OctetString obj:End Sequence:xs2 -> Right (ExtensionRaw oid b obj, xs2) + OctetString obj:End Sequence:xs2 -> Right (ExtensionRaw oid False obj, xs2) + _ -> Left ("fromASN1: X509.ExtensionRaw: unknown format:" ++ show xs) + fromASN1 l = + Left ("fromASN1: X509.ExtensionRaw: unknown format:" ++ show l) + +encodeExt :: ExtensionRaw -> [ASN1] +encodeExt (ExtensionRaw oid critical content) = + asn1Container Sequence ([OID oid] ++ (if critical then [Boolean True] else []) ++ [OctetString content]) diff --git a/Data/X509/Internal.hs b/Data/X509/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Internal.hs @@ -0,0 +1,27 @@ +-- | +-- Module : Data.X509.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Data.X509.Internal + ( module Data.ASN1.Parse + , asn1Container + , OID + -- * error handling + , ErrT + , runErrT + ) where + +import Data.ASN1.Types +import Data.ASN1.Parse +import Control.Monad.Trans.Except + +runErrT :: ExceptT e m a -> m (Either e a) +runErrT = runExceptT +type ErrT = ExceptT + +-- | create a container around the stream of ASN1 +asn1Container :: ASN1ConstructionType -> [ASN1] -> [ASN1] +asn1Container ty l = [Start ty] ++ l ++ [End ty] diff --git a/Data/X509/OID.hs b/Data/X509/OID.hs new file mode 100644 --- /dev/null +++ b/Data/X509/OID.hs @@ -0,0 +1,63 @@ +-- | +-- Module : Data.X509.OID +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Data.X509.OID + ( OIDTable + , lookupByOID + , lookupOID + , curvesOIDTable + ) where + +import Control.Applicative +import Crypto.PubKey.ECC.Types +import Data.ASN1.OID +import Data.List (find) + +type OIDTable a = [(a,OID)] + +lookupByOID :: OIDTable a -> OID -> Maybe a +lookupByOID table oid = fst <$> find ((==) oid . snd) table + +lookupOID :: Eq a => OIDTable a -> a -> Maybe OID +lookupOID table a = lookup a table + +curvesOIDTable :: OIDTable CurveName +curvesOIDTable = + [ (SEC_p112r1, [1,3,132,0,6]) + , (SEC_p112r2, [1,3,132,0,7]) + , (SEC_p128r1, [1,3,132,0,28]) + , (SEC_p128r2, [1,3,132,0,29]) + , (SEC_p160k1, [1,3,132,0,9]) + , (SEC_p160r1, [1,3,132,0,8]) + , (SEC_p160r2, [1,3,132,0,30]) + , (SEC_p192k1, [1,3,132,0,31]) + , (SEC_p192r1, [1,2,840,10045,3,1,1]) + , (SEC_p224k1, [1,3,132,0,32]) + , (SEC_p224r1, [1,3,132,0,33]) + , (SEC_p256k1, [1,3,132,0,10]) + , (SEC_p256r1, [1,2,840,10045,3,1,7]) + , (SEC_p384r1, [1,3,132,0,34]) + , (SEC_p521r1, [1,3,132,0,35]) + , (SEC_t113r1, [1,3,132,0,4]) + , (SEC_t113r2, [1,3,132,0,5]) + , (SEC_t131r1, [1,3,132,0,22]) + , (SEC_t131r2, [1,3,132,0,23]) + , (SEC_t163k1, [1,3,132,0,1]) + , (SEC_t163r1, [1,3,132,0,2]) + , (SEC_t163r2, [1,3,132,0,15]) + , (SEC_t193r1, [1,3,132,0,24]) + , (SEC_t193r2, [1,3,132,0,25]) + , (SEC_t233k1, [1,3,132,0,26]) + , (SEC_t233r1, [1,3,132,0,27]) + , (SEC_t239k1, [1,3,132,0,3]) + , (SEC_t283k1, [1,3,132,0,16]) + , (SEC_t283r1, [1,3,132,0,17]) + , (SEC_t409k1, [1,3,132,0,36]) + , (SEC_t409r1, [1,3,132,0,37]) + , (SEC_t571k1, [1,3,132,0,38]) + , (SEC_t571r1, [1,3,132,0,39]) + ] diff --git a/Data/X509/PrivateKey.hs b/Data/X509/PrivateKey.hs new file mode 100644 --- /dev/null +++ b/Data/X509/PrivateKey.hs @@ -0,0 +1,292 @@ +-- | +-- Module : Data.X509.PublicKey +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Private key handling in X.509 infrastructure +-- +module Data.X509.PrivateKey + ( PrivKey(..) + , PrivKeyEC(..) + , privkeyToAlg + ) where + +import Control.Applicative ((<$>), pure) +import Data.Maybe (fromMaybe) +import Data.Word (Word) + +import Data.ByteArray (ByteArrayAccess, convert) +import qualified Data.ByteString as B + +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import Data.ASN1.BitArray +import Data.ASN1.Stream (getConstructedEnd) + +import Data.X509.AlgorithmIdentifier +import Data.X509.PublicKey (SerializedPoint(..)) +import Data.X509.OID (lookupByOID, lookupOID, curvesOIDTable) + +import Crypto.Error (CryptoFailable(..)) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.Types as ECC +import qualified Crypto.PubKey.Curve25519 as X25519 +import qualified Crypto.PubKey.Curve448 as X448 +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 + +-- | Elliptic Curve Private Key +-- +-- TODO: missing support for binary curve. +data PrivKeyEC = + PrivKeyEC_Prime + { privkeyEC_priv :: Integer + , privkeyEC_a :: Integer + , privkeyEC_b :: Integer + , privkeyEC_prime :: Integer + , privkeyEC_generator :: SerializedPoint + , privkeyEC_order :: Integer + , privkeyEC_cofactor :: Integer + , privkeyEC_seed :: Integer + } + | PrivKeyEC_Named + { privkeyEC_name :: ECC.CurveName + , privkeyEC_priv :: Integer + } + deriving (Show,Eq) + +-- | Private key types known and used in X.509 +data PrivKey = + PrivKeyRSA RSA.PrivateKey -- ^ RSA private key + | PrivKeyDSA DSA.PrivateKey -- ^ DSA private key + | PrivKeyEC PrivKeyEC -- ^ EC private key + | PrivKeyX25519 X25519.SecretKey -- ^ X25519 private key + | PrivKeyX448 X448.SecretKey -- ^ X448 private key + | PrivKeyEd25519 Ed25519.SecretKey -- ^ Ed25519 private key + | PrivKeyEd448 Ed448.SecretKey -- ^ Ed448 private key + deriving (Show,Eq) + +instance ASN1Object PrivKey where + fromASN1 = privkeyFromASN1 + toASN1 = privkeyToASN1 + +privkeyFromASN1 :: [ASN1] -> Either String (PrivKey, [ASN1]) +privkeyFromASN1 asn1 = + (mapFst PrivKeyRSA <$> rsaFromASN1 asn1) + (mapFst PrivKeyDSA <$> dsaFromASN1 asn1) + (mapFst PrivKeyEC <$> ecdsaFromASN1 asn1) + newcurveFromASN1 asn1 + where + mapFst f (a, b) = (f a, b) + + Left _ b = b + a _ = a + +rsaFromASN1 :: [ASN1] -> Either String (RSA.PrivateKey, [ASN1]) +rsaFromASN1 (Start Sequence : IntVal 0 : IntVal n : IntVal e : IntVal d + : IntVal p : IntVal q : IntVal dP : IntVal dQ : IntVal qinv + : End Sequence : as) = pure (key, as) + where + key = RSA.PrivateKey (RSA.PublicKey (go n 1) n e) d p q dP dQ qinv + go m i + | 2 ^ (i * 8) > m = i + | otherwise = go m (i + 1) +rsaFromASN1 (Start Sequence : IntVal 0 : Start Sequence + : OID [1, 2, 840, 113549, 1, 1, 1] : Null : End Sequence + : OctetString bytes : End Sequence : as) = do + asn1 <- mapLeft failure (decodeASN1' BER bytes) + fmap (const as) <$> rsaFromASN1 asn1 + where + failure = ("rsaFromASN1: " ++) . show +rsaFromASN1 _ = Left "rsaFromASN1: unexpected format" + +dsaFromASN1 :: [ASN1] -> Either String (DSA.PrivateKey, [ASN1]) +dsaFromASN1 (Start Sequence : IntVal 0 : IntVal p : IntVal q : IntVal g + : IntVal _ : IntVal x : End Sequence : as) = + pure (DSA.PrivateKey (DSA.Params p g q) x, as) +dsaFromASN1 (Start Sequence : IntVal 0 : Start Sequence + : OID [1, 2, 840, 10040, 4, 1] : Start Sequence : IntVal p : IntVal q + : IntVal g : End Sequence : End Sequence : OctetString bytes + : End Sequence : as) = case decodeASN1' BER bytes of + Right [IntVal x] -> pure (DSA.PrivateKey (DSA.Params p g q) x, as) + Right _ -> Left "DSA.PrivateKey.fromASN1: unexpected format" + Left e -> Left $ "DSA.PrivateKey.fromASN1: " ++ show e +dsaFromASN1 _ = Left "DSA.PrivateKey.fromASN1: unexpected format" + +ecdsaFromASN1 :: [ASN1] -> Either String (PrivKeyEC, [ASN1]) +ecdsaFromASN1 = go [] + where + failing = ("ECDSA.PrivateKey.fromASN1: " ++) + + go acc (Start Sequence : IntVal 1 : OctetString bytes : rest) = do + key <- subgo (oid ++ acc) + case rest'' of + End Sequence : rest''' -> pure (key, rest''') + _ -> Left $ failing "unexpected EC format" + where + d = os2ip bytes + (oid, rest') = spanTag 0 rest + (_, rest'') = spanTag 1 rest' + subgo (OID oid_ : _) = maybe failure success mcurve + where + failure = Left $ failing $ "unknown curve " ++ show oid_ + success = Right . flip PrivKeyEC_Named d + mcurve = lookupByOID curvesOIDTable oid_ + subgo (Start Sequence : IntVal 1 : Start Sequence + : OID [1, 2, 840, 10045, 1, 1] : IntVal p : End Sequence + : Start Sequence : OctetString a : OctetString b : BitString s + : End Sequence : OctetString g : IntVal o : IntVal c + : End Sequence : _) = + pure $ PrivKeyEC_Prime d a' b' p g' o c s' + where + a' = os2ip a + b' = os2ip b + g' = SerializedPoint g + s' = os2ip $ bitArrayGetData s + subgo (Null : rest_) = subgo rest_ + subgo [] = Left $ failing "curve is missing" + subgo _ = Left $ failing "unexpected curve format" + go acc (Start Sequence : IntVal 0 : Start Sequence + : OID [1, 2, 840, 10045, 2, 1] : rest) = case rest' of + (OctetString bytes : rest'') -> do + asn1 <- mapLeft (failing . show) (decodeASN1' BER bytes) + fmap (const rest'') <$> go (oid ++ acc) asn1 + _ -> Left $ failing "unexpected EC format" + where + (oid, rest') = spanEnd 0 rest + go _ _ = Left $ failing "unexpected EC format" + + spanEnd :: Word -> [ASN1] -> ([ASN1], [ASN1]) + spanEnd = loop id + where + loop dlist n (a@(Start _) : as) = loop (dlist . (a :)) (n + 1) as + loop dlist 0 (End _ : as) = (dlist [], as) + loop dlist n (a@(End _) : as) = loop (dlist . (a :)) (n - 1) as + loop dlist n (a : as) = loop (dlist . (a :)) n as + loop dlist _ [] = (dlist [], []) + + spanTag :: Int -> [ASN1] -> ([ASN1], [ASN1]) + spanTag a (Start (Container _ b) : as) | a == b = spanEnd 0 as + spanTag _ as = ([], as) + +newcurveFromASN1 :: [ASN1] -> Either String (PrivKey, [ASN1]) +newcurveFromASN1 ( Start Sequence + : IntVal v + : Start Sequence + : OID oid + : End Sequence + : OctetString bs + : xs) + | isValidVersion v = do + let (_, ys) = containerWithTag 0 xs + case primitiveWithTag 1 ys of + (_, End Sequence : zs) -> + case getP oid of + Just (name, parse) -> do + let err s = Left (name ++ ".SecretKey.fromASN1: " ++ s) + case decodeASN1' BER bs of + Right [OctetString key] -> + case parse key of + CryptoPassed s -> Right (s, zs) + CryptoFailed e -> err ("invalid secret key: " ++ show e) + Right _ -> err "unexpected inner format" + Left e -> err (show e) + Nothing -> Left ("newcurveFromASN1: unexpected OID " ++ show oid) + _ -> Left "newcurveFromASN1: unexpected end format" + | otherwise = Left ("newcurveFromASN1: unexpected version: " ++ show v) + where + getP [1,3,101,110] = Just ("X25519", fmap PrivKeyX25519 . X25519.secretKey) + getP [1,3,101,111] = Just ("X448", fmap PrivKeyX448 . X448.secretKey) + getP [1,3,101,112] = Just ("Ed25519", fmap PrivKeyEd25519 . Ed25519.secretKey) + getP [1,3,101,113] = Just ("Ed448", fmap PrivKeyEd448 . Ed448.secretKey) + getP _ = Nothing + isValidVersion version = version >= 0 && version <= 1 +newcurveFromASN1 _ = + Left "newcurveFromASN1: unexpected format" + +containerWithTag :: ASN1Tag -> [ASN1] -> ([ASN1], [ASN1]) +containerWithTag etag (Start (Container _ atag) : xs) + | etag == atag = getConstructedEnd 0 xs +containerWithTag _ xs = ([], xs) + +primitiveWithTag :: ASN1Tag -> [ASN1] -> (Maybe B.ByteString, [ASN1]) +primitiveWithTag etag (Other _ atag bs : xs) + | etag == atag = (Just bs, xs) +primitiveWithTag _ xs = (Nothing, xs) + +privkeyToASN1 :: PrivKey -> ASN1S +privkeyToASN1 (PrivKeyRSA rsa) = rsaToASN1 rsa +privkeyToASN1 (PrivKeyDSA dsa) = dsaToASN1 dsa +privkeyToASN1 (PrivKeyEC ecdsa) = ecdsaToASN1 ecdsa +privkeyToASN1 (PrivKeyX25519 k) = newcurveToASN1 [1,3,101,110] k +privkeyToASN1 (PrivKeyX448 k) = newcurveToASN1 [1,3,101,111] k +privkeyToASN1 (PrivKeyEd25519 k) = newcurveToASN1 [1,3,101,112] k +privkeyToASN1 (PrivKeyEd448 k) = newcurveToASN1 [1,3,101,113] k + +rsaToASN1 :: RSA.PrivateKey -> ASN1S +rsaToASN1 key = (++) + [ Start Sequence, IntVal 0, IntVal n, IntVal e, IntVal d, IntVal p + , IntVal q, IntVal dP, IntVal dQ, IntVal qinv, End Sequence + ] + where + RSA.PrivateKey (RSA.PublicKey _ n e) d p q dP dQ qinv = key + +dsaToASN1 :: DSA.PrivateKey -> ASN1S +dsaToASN1 (DSA.PrivateKey params@(DSA.Params p g q) y) = (++) + [ Start Sequence, IntVal 0, IntVal p, IntVal q, IntVal g, IntVal x + , IntVal y, End Sequence + ] + where + x = DSA.calculatePublic params y + +ecdsaToASN1 :: PrivKeyEC -> ASN1S +ecdsaToASN1 (PrivKeyEC_Named curveName d) = (++) + [ Start Sequence, IntVal 1, OctetString (i2osp d) + , Start (Container Context 0), OID oid, End (Container Context 0) + , End Sequence + ] + where + err = error . ("ECDSA.PrivateKey.toASN1: " ++) + oid = fromMaybe (err $ "missing named curve " ++ show curveName) + (lookupOID curvesOIDTable curveName) +ecdsaToASN1 (PrivKeyEC_Prime d a b p g o c s) = (++) + [ Start Sequence, IntVal 1, OctetString (i2osp d) + , Start (Container Context 0), Start Sequence, IntVal 1 + , Start Sequence, OID [1, 2, 840, 10045, 1, 1], IntVal p, End Sequence + , Start Sequence, OctetString a', OctetString b', BitString s' + , End Sequence, OctetString g' , IntVal o, IntVal c, End Sequence + , End (Container Context 0), End Sequence + ] + where + a' = i2osp a + b' = i2osp b + SerializedPoint g' = g + s' = BitArray (8 * fromIntegral (B.length bytes)) bytes + where + bytes = i2osp s + +newcurveToASN1 :: ByteArrayAccess key => OID -> key -> ASN1S +newcurveToASN1 oid key = (++) + [ Start Sequence, IntVal 0, Start Sequence, OID oid, End Sequence + , OctetString (encodeASN1' DER [OctetString $ convert key]) + , End Sequence + ] + +mapLeft :: (a0 -> a1) -> Either a0 b -> Either a1 b +mapLeft f (Left x) = Left (f x) +mapLeft _ (Right x) = Right x + +-- | Convert a Private key to the Public Key Algorithm type +privkeyToAlg :: PrivKey -> PubKeyALG +privkeyToAlg (PrivKeyRSA _) = PubKeyALG_RSA +privkeyToAlg (PrivKeyDSA _) = PubKeyALG_DSA +privkeyToAlg (PrivKeyEC _) = PubKeyALG_EC +privkeyToAlg (PrivKeyX25519 _) = PubKeyALG_X25519 +privkeyToAlg (PrivKeyX448 _) = PubKeyALG_X448 +privkeyToAlg (PrivKeyEd25519 _) = PubKeyALG_Ed25519 +privkeyToAlg (PrivKeyEd448 _) = PubKeyALG_Ed448 diff --git a/Data/X509/PublicKey.hs b/Data/X509/PublicKey.hs new file mode 100644 --- /dev/null +++ b/Data/X509/PublicKey.hs @@ -0,0 +1,279 @@ +-- | +-- Module : Data.X509.PublicKey +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Public key handling in X.509 infrastructure +-- +module Data.X509.PublicKey + ( PubKey(..) + , PubKeyEC(..) + , SerializedPoint(..) + , pubkeyToAlg + ) where + +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import Data.ASN1.BitArray + +import Data.Bits +import Data.ByteArray (convert) +import Data.ByteString (ByteString) + +import Data.X509.Internal +import Data.X509.OID +import Data.X509.AlgorithmIdentifier + +import Crypto.Error (CryptoFailable(..)) +import qualified Crypto.PubKey.RSA.Types as RSA +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.Types as ECC +import qualified Crypto.PubKey.Curve25519 as X25519 +import qualified Crypto.PubKey.Curve448 as X448 +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import Crypto.Number.Basic (numBytes) +import Crypto.Number.Serialize (os2ip) +import Data.Word + +import qualified Data.ByteString as B + +-- | Serialized Elliptic Curve Point +newtype SerializedPoint = SerializedPoint ByteString + deriving (Show,Eq) + +-- | Elliptic Curve Public Key +-- +-- TODO: missing support for binary curve. +data PubKeyEC = + PubKeyEC_Prime + { pubkeyEC_pub :: SerializedPoint + , pubkeyEC_a :: Integer + , pubkeyEC_b :: Integer + , pubkeyEC_prime :: Integer + , pubkeyEC_generator :: SerializedPoint + , pubkeyEC_order :: Integer + , pubkeyEC_cofactor :: Integer + , pubkeyEC_seed :: Integer + } + | PubKeyEC_Named + { pubkeyEC_name :: ECC.CurveName + , pubkeyEC_pub :: SerializedPoint + } + deriving (Show,Eq) + +-- | Public key types known and used in X.509 +data PubKey = + PubKeyRSA RSA.PublicKey -- ^ RSA public key + | PubKeyDSA DSA.PublicKey -- ^ DSA public key + | PubKeyDH (Integer,Integer,Integer,Maybe Integer,([Word8], Integer)) + -- ^ DH format with (p,g,q,j,(seed,pgenCounter)) + | PubKeyEC PubKeyEC -- ^ EC public key + | PubKeyX25519 X25519.PublicKey -- ^ X25519 public key + | PubKeyX448 X448.PublicKey -- ^ X448 public key + | PubKeyEd25519 Ed25519.PublicKey -- ^ Ed25519 public key + | PubKeyEd448 Ed448.PublicKey -- ^ Ed448 public key + | PubKeyUnknown OID B.ByteString -- ^ unrecognized format + deriving (Show,Eq) + +-- Public key are in the format: +-- +-- Start Sequence +-- OID (Public key algorithm) +-- [public key specific format] +-- BitString +-- End Sequence +instance ASN1Object PubKey where + fromASN1 (Start Sequence:Start Sequence:OID pkalg:xs) + | pkalg == getObjectID PubKeyALG_RSA = + case removeNull xs of + End Sequence:BitString bits:End Sequence:xs2 -> decodeASN1Err "RSA" bits xs2 (toPubKeyRSA . rsaPubFromASN1) + _ -> Left ("fromASN1: X509.PubKey: unknown RSA format: " ++ show xs) + | pkalg == getObjectID PubKeyALG_DSA = + case xs of + Start Sequence:IntVal p:IntVal q:IntVal g:End Sequence:End Sequence:BitString bits:End Sequence:xs2 -> + decodeASN1Err "DSA" bits xs2 (\l -> case l of + [IntVal dsapub] -> + let pubkey = DSA.PublicKey { DSA.public_params = DSA.Params { DSA.params_p = p + , DSA.params_q = q + , DSA.params_g = g + } + , DSA.public_y = dsapub } + in Right (PubKeyDSA pubkey, []) + _ -> Left "fromASN1: X509.PubKey: unknown DSA format" + ) + _ -> Left "fromASN1: X509.PubKey: unknown DSA format" + | pkalg == getObjectID PubKeyALG_EC = + case xs of + OID curveOid:End Sequence:BitString bits:End Sequence:xs2 -> + case lookupByOID curvesOIDTable curveOid of + Just curveName -> Right (PubKeyEC $ PubKeyEC_Named curveName (bitArrayToPoint bits), xs2) + Nothing -> Left ("fromASN1: X509.Pubkey: EC unknown curve " ++ show curveOid) + Start Sequence + :IntVal 1 + :Start Sequence + :OID [1,2,840,10045,1,1] + :IntVal prime + :End Sequence + :Start Sequence + :OctetString a + :OctetString b + :BitString seed + :End Sequence + :OctetString generator + :IntVal order + :IntVal cofactor + :End Sequence + :End Sequence + :BitString pub + :End Sequence + :xs2 -> + Right (PubKeyEC $ PubKeyEC_Prime + { pubkeyEC_pub = bitArrayToPoint pub + , pubkeyEC_a = os2ip a + , pubkeyEC_b = os2ip b + , pubkeyEC_prime = prime + , pubkeyEC_generator = SerializedPoint generator + , pubkeyEC_order = order + , pubkeyEC_cofactor = cofactor + , pubkeyEC_seed = os2ip $ bitArrayGetData seed + }, xs2) + _ -> + Left $ "fromASN1: X509.PubKey: unknown EC format: " ++ show xs + | pkalg == getObjectID PubKeyALG_X25519 = + case xs of + End Sequence:BitString bits:End Sequence:xs2 -> decodeCF "X25519" PubKeyX25519 bits xs2 X25519.publicKey + _ -> Left ("fromASN1: X509.PubKey: unknown X25519 format: " ++ show xs) + | pkalg == getObjectID PubKeyALG_X448 = + case xs of + End Sequence:BitString bits:End Sequence:xs2 -> decodeCF "X448" PubKeyX448 bits xs2 X448.publicKey + _ -> Left ("fromASN1: X509.PubKey: unknown X448 format: " ++ show xs) + | pkalg == getObjectID PubKeyALG_Ed25519 = + case xs of + End Sequence:BitString bits:End Sequence:xs2 -> decodeCF "Ed25519" PubKeyEd25519 bits xs2 Ed25519.publicKey + _ -> Left ("fromASN1: X509.PubKey: unknown Ed25519 format: " ++ show xs) + | pkalg == getObjectID PubKeyALG_Ed448 = + case xs of + End Sequence:BitString bits:End Sequence:xs2 -> decodeCF "Ed448" PubKeyEd448 bits xs2 Ed448.publicKey + _ -> Left ("fromASN1: X509.PubKey: unknown Ed448 format: " ++ show xs) + | otherwise = Left $ "fromASN1: unknown public key OID: " ++ show pkalg + where decodeASN1Err format bits xs2 f = + case decodeASN1' BER (bitArrayGetData bits) of + Left err -> Left ("fromASN1: X509.PubKey " ++ format ++ " bitarray cannot be parsed: " ++ show err) + Right s -> case f s of + Left err -> Left err + Right (r, xsinner) -> Right (r, xsinner ++ xs2) + toPubKeyRSA = either Left (\(rsaKey, r) -> Right (PubKeyRSA rsaKey, r)) + + bitArrayToPoint = SerializedPoint . bitArrayGetData + + removeNull (Null:r) = r + removeNull l = l + + decodeCF format c bits xs2 f = case f (bitArrayGetData bits) of + CryptoPassed pk -> Right (c pk, xs2) + CryptoFailed err -> Left ("fromASN1: X509.PubKey " ++ format ++ " bitarray contains an invalid public key: " ++ show err) + + fromASN1 l = Left ("fromASN1: X509.PubKey: unknown format:" ++ show l) + toASN1 a = \xs -> encodePK a ++ xs + +-- | Convert a Public key to the Public Key Algorithm type +pubkeyToAlg :: PubKey -> PubKeyALG +pubkeyToAlg (PubKeyRSA _) = PubKeyALG_RSA +pubkeyToAlg (PubKeyDSA _) = PubKeyALG_DSA +pubkeyToAlg (PubKeyDH _) = PubKeyALG_DH +pubkeyToAlg (PubKeyEC _) = PubKeyALG_EC +pubkeyToAlg (PubKeyX25519 _) = PubKeyALG_X25519 +pubkeyToAlg (PubKeyX448 _) = PubKeyALG_X448 +pubkeyToAlg (PubKeyEd25519 _) = PubKeyALG_Ed25519 +pubkeyToAlg (PubKeyEd448 _) = PubKeyALG_Ed448 +pubkeyToAlg (PubKeyUnknown oid _) = PubKeyALG_Unknown oid + +encodePK :: PubKey -> [ASN1] +encodePK key = asn1Container Sequence (encodeInner key) + where + pkalg = OID $ getObjectID $ pubkeyToAlg key + encodeInner (PubKeyRSA pubkey) = + asn1Container Sequence [pkalg,Null] ++ [BitString $ toBitArray bits 0] + where bits = encodeASN1' DER $ rsaPubToASN1 pubkey [] + encodeInner (PubKeyDSA pubkey) = + asn1Container Sequence ([pkalg] ++ dsaseq) ++ [BitString $ toBitArray bits 0] + where + dsaseq = asn1Container Sequence [IntVal (DSA.params_p params) + ,IntVal (DSA.params_q params) + ,IntVal (DSA.params_g params)] + params = DSA.public_params pubkey + bits = encodeASN1' DER [IntVal $ DSA.public_y pubkey] + encodeInner (PubKeyEC (PubKeyEC_Named curveName (SerializedPoint bits))) = + asn1Container Sequence [pkalg,OID eOid] ++ [BitString $ toBitArray bits 0] + where + eOid = case lookupOID curvesOIDTable curveName of + Just oid -> oid + _ -> error ("undefined curve OID: " ++ show curveName) + encodeInner (PubKeyEC (PubKeyEC_Prime {})) = + error "encodeInner: unimplemented public key EC_Prime" + encodeInner (PubKeyX25519 pubkey) = + asn1Container Sequence [pkalg] ++ [BitString $ toBitArray (convert pubkey) 0] + encodeInner (PubKeyX448 pubkey) = + asn1Container Sequence [pkalg] ++ [BitString $ toBitArray (convert pubkey) 0] + encodeInner (PubKeyEd25519 pubkey) = + asn1Container Sequence [pkalg] ++ [BitString $ toBitArray (convert pubkey) 0] + encodeInner (PubKeyEd448 pubkey) = + asn1Container Sequence [pkalg] ++ [BitString $ toBitArray (convert pubkey) 0] + encodeInner (PubKeyDH _) = error "encodeInner: unimplemented public key DH" + encodeInner (PubKeyUnknown _ l) = + asn1Container Sequence [pkalg,Null] ++ [BitString $ toBitArray l 0] + +rsaPubToASN1 :: RSA.PublicKey -> [ASN1] -> [ASN1] +rsaPubToASN1 pubkey xs = + Start Sequence : IntVal (RSA.public_n pubkey) : IntVal (RSA.public_e pubkey) : End Sequence : xs + +rsaPubFromASN1 :: [ASN1] -> Either String (RSA.PublicKey, [ASN1]) +rsaPubFromASN1 (Start Sequence:IntVal smodulus:IntVal pubexp:End Sequence:xs) = + Right (pub, xs) + where + pub = RSA.PublicKey { RSA.public_size = numBytes modulus + , RSA.public_n = modulus + , RSA.public_e = pubexp + } + -- some bad implementation will not serialize ASN.1 integer properly, leading + -- to negative modulus. if that's the case, we correct it. + modulus = toPositive smodulus + +rsaPubFromASN1 ( Start Sequence + : IntVal ver + : Start Sequence + : OID oid + : Null + : End Sequence + : OctetString bs + : xs + ) + | ver /= 0 = Left "rsaPubFromASN1: Invalid version, expecting 0" + | oid /= [1,2,840,113549,1,1,1] = + Left "rsaPubFromASN1: invalid OID" + | otherwise = + let inner = either strError rsaPubFromASN1 $ decodeASN1' BER bs + strError = Left . ("fromASN1: RSA.PublicKey: " ++) . show + in either Left (\(k, _) -> Right (k, xs)) inner +rsaPubFromASN1 _ = + Left "fromASN1: RSA.PublicKey: unexpected format" + +-- some bad implementation will not serialize ASN.1 integer properly, leading +-- to negative modulus. +toPositive :: Integer -> Integer +toPositive int + | int < 0 = uintOfBytes $ bytesOfInt int + | otherwise = int + where + uintOfBytes = foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 + bytesOfInt :: Integer -> [Word8] + bytesOfInt n = if testBit (head nints) 7 then nints else 0xff : nints + where nints = reverse $ plusOne $ reverse $ map complement $ bytesOfUInt (abs n) + plusOne [] = [1] + plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs + bytesOfUInt x = reverse (list x) + where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8) diff --git a/Data/X509/Signed.hs b/Data/X509/Signed.hs new file mode 100644 --- /dev/null +++ b/Data/X509/Signed.hs @@ -0,0 +1,171 @@ +-- | +-- Module : Data.X509.Signed +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Exposes helpers for X509 certificate and revocation list, signed structures. +-- +-- Signed structures are of the form: +-- Sequence { +-- object a +-- signatureAlgorithm AlgorithmIdentifier +-- signatureValue BitString +-- } +-- +-- Unfortunately as lots of signed objects published have been signed on an +-- arbitrary BER ASN1 encoding (instead of using the unique DER encoding) or in +-- a non-valid DER implementation, we need to keep the raw data being signed, +-- as we can't recompute the bytestring used to sign for non compliant cases. +-- +-- Signed represent the pure data type for compliant cases, and SignedExact +-- the real world situation of having to deal with compliant and non-compliant cases. +-- +module Data.X509.Signed + ( + -- * Types + Signed(..) + , SignedExact + -- * SignedExact to Signed + , getSigned + , getSignedData + -- * Marshalling function + , encodeSignedObject + , decodeSignedObject + -- * Object to Signed and SignedExact + , objectToSignedExact + , objectToSignedExactF + , objectToSigned + , signedToExact + ) where + +import Control.Arrow (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.X509.AlgorithmIdentifier +import Data.ASN1.Types +import Data.ASN1.Encoding +import Data.ASN1.BinaryEncoding +import Data.ASN1.Stream +import Data.ASN1.BitArray +import qualified Data.ASN1.BinaryEncoding.Raw as Raw (toByteString) + +-- | Represent a signed object using a traditional X509 structure. +-- +-- When dealing with external certificate, use the SignedExact structure +-- not this one. +data (Show a, Eq a, ASN1Object a) => Signed a = Signed + { signedObject :: a -- ^ Object to sign + , signedAlg :: SignatureALG -- ^ Signature Algorithm used + , signedSignature :: B.ByteString -- ^ Signature as bytes + } deriving (Show, Eq) + +-- | Represent the signed object plus the raw data that we need to +-- keep around for non compliant case to be able to verify signature. +data (Show a, Eq a, ASN1Object a) => SignedExact a = SignedExact + { getSigned :: Signed a -- ^ get the decoded Signed data + , exactObjectRaw :: B.ByteString -- ^ The raw representation of the object a + -- TODO: in later version, replace with offset in exactRaw + , encodeSignedObject :: B.ByteString -- ^ The raw representation of the whole signed structure + } deriving (Show, Eq) + +-- | Get the signed data for the signature +getSignedData :: (Show a, Eq a, ASN1Object a) + => SignedExact a + -> B.ByteString +getSignedData = exactObjectRaw + +-- | make a 'SignedExact' copy of a 'Signed' object +-- +-- As the signature is already generated, expect the +-- encoded object to have been made on a compliant DER ASN1 implementation. +-- +-- It's better to use 'objectToSignedExact' instead of this. +signedToExact :: (Show a, Eq a, ASN1Object a) + => Signed a + -> SignedExact a +signedToExact signed = sExact + where (sExact, ()) = objectToSignedExact fakeSigFunction (signedObject signed) + fakeSigFunction _ = (signedSignature signed, signedAlg signed, ()) + +-- | Transform an object into a 'SignedExact' object +objectToSignedExact :: (Show a, Eq a, ASN1Object a) + => (ByteString -> (ByteString, SignatureALG, r)) -- ^ signature function + -> a -- ^ object to sign + -> (SignedExact a, r) +objectToSignedExact signatureFunction object = (signedExact, val) + where + (val, signedExact) = objectToSignedExactF (wrap . signatureFunction) object + wrap (b, s, r) = (r, (b, s)) + +-- | A generalization of 'objectToSignedExact' where the signature function +-- runs in an arbitrary functor. This allows for example to sign using an +-- algorithm needing random values. +objectToSignedExactF :: (Functor f, Show a, Eq a, ASN1Object a) + => (ByteString -> f (ByteString, SignatureALG)) -- ^ signature function + -> a -- ^ object to sign + -> f (SignedExact a) +objectToSignedExactF signatureFunction object = fmap buildSignedExact (signatureFunction objRaw) + where buildSignedExact (sigBits,sigAlg) = + let signed = Signed { signedObject = object + , signedAlg = sigAlg + , signedSignature = sigBits + } + signedRaw = encodeASN1' DER signedASN1 + signedASN1 = Start Sequence + : objASN1 + (toASN1 sigAlg + (BitString (toBitArray sigBits 0) + : End Sequence + : [])) + in SignedExact signed objRaw signedRaw + objASN1 = \xs -> Start Sequence : toASN1 object (End Sequence : xs) + objRaw = encodeASN1' DER (objASN1 []) + +-- | Transform an object into a 'Signed' object. +-- +-- It's recommended to use the SignedExact object instead of Signed. +objectToSigned :: (Show a, Eq a, ASN1Object a) + => (ByteString + -> (ByteString, SignatureALG, r)) + -> a + -> (Signed a, r) +objectToSigned signatureFunction object = first getSigned $ objectToSignedExact signatureFunction object + +-- | Try to parse a bytestring that use the typical X509 signed structure format +decodeSignedObject :: (Show a, Eq a, ASN1Object a) + => ByteString + -> Either String (SignedExact a) +decodeSignedObject b = either (Left . show) parseSigned $ decodeASN1Repr' BER b + where -- the following implementation is very inefficient. + -- uses reverse and containing, move to a better solution eventually + parseSigned l = onContainer (fst $ getConstructedEndRepr l) $ \l2 -> + let (objRepr,rem1) = getConstructedEndRepr l2 + (sigAlgSeq,rem2) = getConstructedEndRepr rem1 + (sigSeq,_) = getConstructedEndRepr rem2 + obj = onContainer objRepr (either Left Right . fromASN1 . map fst) + in case (obj, map fst sigSeq) of + (Right (o,[]), [BitString signature]) -> + let rawObj = Raw.toByteString $ concatMap snd objRepr + in case fromASN1 $ map fst sigAlgSeq of + Left s -> Left ("signed object error sigalg: " ++ s) + Right (sigAlg,_) -> + let signed = Signed + { signedObject = o + , signedAlg = sigAlg + , signedSignature = bitArrayGetData signature + } + in Right $ SignedExact + { getSigned = signed + , exactObjectRaw = rawObj + , encodeSignedObject = b + } + (Right (_,remObj), _) -> + Left $ ("signed object error: remaining stream in object: " ++ show remObj) + (Left err, _) -> Left $ ("signed object error: " ++ show err) + onContainer ((Start _, _) : l) f = + case reverse l of + ((End _, _) : l2) -> f $ reverse l2 + _ -> f [] + onContainer _ f = f [] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010-2013 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tests/Tests.hs b/Tests/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests/Tests.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Data.ByteString as B + +import Control.Applicative +import Control.Monad + +import Data.List (nub, sort) +import Data.ASN1.Types +import Data.X509 +import Crypto.Error (throwCryptoError) +import qualified Crypto.PubKey.Curve25519 as X25519 +import qualified Crypto.PubKey.Curve448 as X448 +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.DSA as DSA + +import Data.Hourglass + +instance Arbitrary RSA.PublicKey where + arbitrary = do + bytes <- elements [64,128,256] + e <- elements [0x3,0x10001] + n <- choose (2^(8*(bytes-1)),2^(8*bytes)) + return $ RSA.PublicKey { RSA.public_size = bytes + , RSA.public_n = n + , RSA.public_e = e + } + +instance Arbitrary DSA.Params where + arbitrary = DSA.Params <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary DSA.PublicKey where + arbitrary = DSA.PublicKey <$> arbitrary <*> arbitrary + +instance Arbitrary X25519.PublicKey where + arbitrary = X25519.toPublic <$> arbitrary + +instance Arbitrary X448.PublicKey where + arbitrary = X448.toPublic <$> arbitrary + +instance Arbitrary Ed25519.PublicKey where + arbitrary = Ed25519.toPublic <$> arbitrary + +instance Arbitrary Ed448.PublicKey where + arbitrary = Ed448.toPublic <$> arbitrary + +instance Arbitrary PubKey where + arbitrary = oneof + [ PubKeyRSA <$> arbitrary + , PubKeyDSA <$> arbitrary + --, PubKeyECDSA ECDSA_Hash_SHA384 <$> (B.pack <$> replicateM 384 arbitrary) + , PubKeyX25519 <$> arbitrary + , PubKeyX448 <$> arbitrary + , PubKeyEd25519 <$> arbitrary + , PubKeyEd448 <$> arbitrary + ] + +instance Arbitrary RSA.PrivateKey where + arbitrary = RSA.PrivateKey <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary DSA.PrivateKey where + arbitrary = DSA.PrivateKey <$> arbitrary <*> arbitrary + +instance Arbitrary X25519.SecretKey where + arbitrary = throwCryptoError . X25519.secretKey <$> arbitraryBS 32 32 + +instance Arbitrary X448.SecretKey where + arbitrary = throwCryptoError . X448.secretKey <$> arbitraryBS 56 56 + +instance Arbitrary Ed25519.SecretKey where + arbitrary = throwCryptoError . Ed25519.secretKey <$> arbitraryBS 32 32 + +instance Arbitrary Ed448.SecretKey where + arbitrary = throwCryptoError . Ed448.secretKey <$> arbitraryBS 57 57 + +instance Arbitrary PrivKey where + arbitrary = oneof + [ PrivKeyRSA <$> arbitrary + , PrivKeyDSA <$> arbitrary + --, PrivKeyECDSA ECDSA_Hash_SHA384 <$> (B.pack <$> replicateM 384 arbitrary) + , PrivKeyX25519 <$> arbitrary + , PrivKeyX448 <$> arbitrary + , PrivKeyEd25519 <$> arbitrary + , PrivKeyEd448 <$> arbitrary + ] + +instance Arbitrary HashALG where + arbitrary = elements [HashMD2,HashMD5,HashSHA1,HashSHA224,HashSHA256,HashSHA384,HashSHA512] + +instance Arbitrary PubKeyALG where + arbitrary = elements [PubKeyALG_RSA,PubKeyALG_DSA,PubKeyALG_EC,PubKeyALG_DH] + +instance Arbitrary SignatureALG where + -- unfortunately as the encoding of this is a single OID as opposed to two OID, + -- the testing need to limit itself to Signature ALG that has been defined in the OID database. + -- arbitrary = SignatureALG <$> arbitrary <*> arbitrary + 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 + , SignatureALG_IntrinsicHash PubKeyALG_Ed25519 + , SignatureALG_IntrinsicHash PubKeyALG_Ed448 + ] + +arbitraryBS r1 r2 = choose (r1,r2) >>= \l -> (B.pack <$> replicateM l arbitrary) + +instance Arbitrary ASN1StringEncoding where + arbitrary = elements [IA5,UTF8] + +instance Arbitrary ASN1CharacterString where + arbitrary = ASN1CharacterString <$> arbitrary <*> arbitraryBS 2 36 + +instance Arbitrary DistinguishedName where + arbitrary = DistinguishedName <$> (choose (1,5) >>= \l -> replicateM l arbitraryDE) + where arbitraryDE = (,) <$> arbitrary <*> arbitrary + +instance Arbitrary DateTime where + arbitrary = timeConvert <$> (arbitrary :: Gen Elapsed) +instance Arbitrary Elapsed where + arbitrary = Elapsed . Seconds <$> (choose (1, 100000000)) + +instance Arbitrary Extensions where + arbitrary = Extensions <$> oneof + [ pure Nothing + , Just <$> (listOf1 $ oneof + [ extensionEncode <$> arbitrary <*> (arbitrary :: Gen ExtKeyUsage) + ] + ) + ] + +instance Arbitrary ExtKeyUsageFlag where + arbitrary = elements $ enumFrom KeyUsage_digitalSignature +instance Arbitrary ExtKeyUsage where + arbitrary = ExtKeyUsage . sort . nub <$> listOf1 arbitrary + +instance Arbitrary ExtKeyUsagePurpose where + arbitrary = elements [ KeyUsagePurpose_ServerAuth + , KeyUsagePurpose_ClientAuth + , KeyUsagePurpose_CodeSigning + , KeyUsagePurpose_EmailProtection + , KeyUsagePurpose_TimeStamping + , KeyUsagePurpose_OCSPSigning ] +instance Arbitrary ExtExtendedKeyUsage where + arbitrary = ExtExtendedKeyUsage . nub <$> listOf1 arbitrary + +instance Arbitrary Certificate where + arbitrary = Certificate <$> pure 2 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary RevokedCertificate where + arbitrary = RevokedCertificate <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary CRL where + arbitrary = CRL <$> pure 1 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +property_unmarshall_marshall_id :: (Show o, Arbitrary o, ASN1Object o, Eq o) => o -> Bool +property_unmarshall_marshall_id o = + case got of + Right (gotObject, []) + | gotObject == o -> True + | otherwise -> error ("object is different: " ++ show gotObject ++ " expecting " ++ show o) + Right (gotObject, l) -> error ("state remaining: " ++ show l ++ " marshalled: " ++ show oMarshalled ++ " parsed: " ++ show gotObject) + Left e -> error ("parsing failed: " ++ show e ++ " object: " ++ show o ++ " marshalled as: " ++ show oMarshalled) + where got = fromASN1 oMarshalled + oMarshalled = toASN1 o [] + +property_extension_id :: (Show e, Eq e, Extension e) => e -> Bool +property_extension_id e = case extDecode (extEncode e) of + Left err -> error err + Right v | v == e -> True + | otherwise -> error ("expected " ++ show e ++ " got: " ++ show v) + +main = defaultMain $ testGroup "X509" + [ testGroup "marshall" + [ testProperty "pubkey" (property_unmarshall_marshall_id :: PubKey -> Bool) + , testProperty "privkey" (property_unmarshall_marshall_id :: PrivKey -> Bool) + , testProperty "signature alg" (property_unmarshall_marshall_id :: SignatureALG -> Bool) + , testGroup "extension" + [ testProperty "key-usage" (property_extension_id :: ExtKeyUsage -> Bool) + , testProperty "extended-key-usage" (property_extension_id :: ExtExtendedKeyUsage -> Bool) + ] + , testProperty "extensions" (property_unmarshall_marshall_id :: Extensions -> Bool) + , testProperty "certificate" (property_unmarshall_marshall_id :: Certificate -> Bool) + , testProperty "crl" (property_unmarshall_marshall_id :: CRL -> Bool) + ] + ] diff --git a/crypton-x509.cabal b/crypton-x509.cabal new file mode 100644 --- /dev/null +++ b/crypton-x509.cabal @@ -0,0 +1,64 @@ +Name: crypton-x509 +version: 1.7.6 +Description: X509 reader and writer. please see README +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: Kazu Yamamoto +Synopsis: X509 reader and writer +Build-Type: Simple +Category: Data +stability: experimental +Homepage: http://github.com/vincenthz/hs-certificate +Cabal-Version: >= 1.10 + +Library + Default-Language: Haskell2010 + Build-Depends: base >= 4.7 && < 5 + , bytestring + , memory + , transformers >= 0.4 + , containers + , hourglass + , pem >= 0.1 + , asn1-types >= 0.3.1 && < 0.4 + , asn1-encoding >= 0.9 && < 0.10 + , asn1-parse >= 0.9.3 && < 0.10 + , crypton >= 0.24 + Exposed-modules: Data.X509 + Data.X509.EC + Other-modules: Data.X509.Internal + Data.X509.CertificateChain + Data.X509.AlgorithmIdentifier + Data.X509.DistinguishedName + Data.X509.Cert + Data.X509.PublicKey + Data.X509.PrivateKey + Data.X509.Ext + Data.X509.ExtensionRaw + Data.X509.CRL + Data.X509.OID + Data.X509.Signed + ghc-options: -Wall + +Test-Suite test-x509 + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: Tests + Main-is: Tests.hs + Build-Depends: base >= 3 && < 5 + , bytestring + , mtl + , tasty + , tasty-quickcheck + , hourglass + , asn1-types + , x509 + , crypton + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + +source-repository head + type: git + location: https://github.com/kazu-yamamoto/crypton-certificate + subdir: x509