crypton-x509 (empty) → 1.7.6
raw patch · 18 files changed
+2314/−0 lines, 18 filesdep +asn1-encodingdep +asn1-parsedep +asn1-typessetup-changed
Dependencies added: asn1-encoding, asn1-parse, asn1-types, base, bytestring, containers, crypton, hourglass, memory, mtl, pem, tasty, tasty-quickcheck, transformers, x509
Files
- Data/X509.hs +125/−0
- Data/X509/AlgorithmIdentifier.hs +120/−0
- Data/X509/CRL.hs +119/−0
- Data/X509/Cert.hs +123/−0
- Data/X509/CertificateChain.hs +42/−0
- Data/X509/DistinguishedName.hs +97/−0
- Data/X509/EC.hs +126/−0
- Data/X509/Ext.hs +350/−0
- Data/X509/ExtensionRaw.hs +64/−0
- Data/X509/Internal.hs +27/−0
- Data/X509/OID.hs +63/−0
- Data/X509/PrivateKey.hs +292/−0
- Data/X509/PublicKey.hs +279/−0
- Data/X509/Signed.hs +171/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- Tests/Tests.hs +223/−0
- crypton-x509.cabal +64/−0
+ Data/X509.hs view
@@ -0,0 +1,125 @@+-- |+-- Module : Data.X509+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/AlgorithmIdentifier.hs view
@@ -0,0 +1,120 @@+-- |+-- Module : Data.X509.AlgorithmIdentifier+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/CRL.hs view
@@ -0,0 +1,119 @@+-- |+-- Module : Data.X509.CRL+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 []
+ Data/X509/Cert.hs view
@@ -0,0 +1,123 @@+-- |+-- Module : Data.X509.Cert+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/CertificateChain.hs view
@@ -0,0 +1,42 @@+-- |+-- Module : Data.X509.CertificateChain+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/DistinguishedName.hs view
@@ -0,0 +1,97 @@+-- |+-- Module : Data.X509.DistinguishedName+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/EC.hs view
@@ -0,0 +1,126 @@+-- |+-- Module : Data.X509.EC+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/Ext.hs view
@@ -0,0 +1,350 @@+-- |+-- Module : Data.X509.Ext+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/ExtensionRaw.hs view
@@ -0,0 +1,64 @@+-- |+-- Module : Data.X509.ExtensionRaw+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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])
+ Data/X509/Internal.hs view
@@ -0,0 +1,27 @@+-- |+-- Module : Data.X509.Internal+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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]
+ Data/X509/OID.hs view
@@ -0,0 +1,63 @@+-- |+-- Module : Data.X509.OID+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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])+ ]
+ Data/X509/PrivateKey.hs view
@@ -0,0 +1,292 @@+-- |+-- Module : Data.X509.PublicKey+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Data/X509/PublicKey.hs view
@@ -0,0 +1,279 @@+-- |+-- Module : Data.X509.PublicKey+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ Data/X509/Signed.hs view
@@ -0,0 +1,171 @@+-- |+-- Module : Data.X509.Signed+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 []
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests/Tests.hs view
@@ -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)+ ]+ ]
+ crypton-x509.cabal view
@@ -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 <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+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