diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,6 @@ +# ChangeLog for x509 + +## 2022-05-31 v1.7.7 + +- Bump requirements to GHC 7.8 and transformers 0.4 series [#130](https://github.com/haskell-tls/hs-certificate/pull/130) + diff --git a/Data/X509.hs b/Data/X509.hs --- a/Data/X509.hs +++ b/Data/X509.hs @@ -16,7 +16,10 @@ , SignedCRL , Certificate(..) , PubKey(..) + , PubKeyEC(..) + , SerializedPoint(..) , PrivKey(..) + , PrivKeyEC(..) , pubkeyToAlg , privkeyToAlg , module Data.X509.AlgorithmIdentifier @@ -41,6 +44,7 @@ , getSigned , getSignedData , objectToSignedExact + , objectToSignedExactF , encodeSignedObject , decodeSignedObject @@ -61,6 +65,7 @@ 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 @@ -73,8 +78,7 @@ import Data.X509.PrivateKey import Data.X509.AlgorithmIdentifier -import qualified Crypto.Hash.MD5 as MD5 -import qualified Crypto.Hash.SHA1 as SHA1 +import Crypto.Hash -- | A Signed Certificate type SignedCertificate = SignedExact Certificate @@ -103,7 +107,7 @@ -- OpenSSL algorithm is odd, and has been replicated here somewhat. -- only lower the case of ascii character. hashDN :: DistinguishedName -> B.ByteString -hashDN = shorten . SHA1.hash . encodeASN1' DER . flip toASN1 [] . DistinguishedNameInner . dnLowerUTF8 +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 @@ -114,8 +118,8 @@ -- | Create an openssl style old hash of distinguished name hashDN_old :: DistinguishedName -> B.ByteString -hashDN_old = shorten . MD5.hash . encodeASN1' DER . flip toASN1 [] +hashDN_old = shorten . hashWith MD5 . encodeASN1' DER . flip toASN1 [] -shorten :: B.ByteString -> B.ByteString +shorten :: Digest a -> B.ByteString shorten b = B.pack $ map i [3,2,1,0] - where i n = B.index b n + where i n = BA.index b n diff --git a/Data/X509/AlgorithmIdentifier.hs b/Data/X509/AlgorithmIdentifier.hs --- a/Data/X509/AlgorithmIdentifier.hs +++ b/Data/X509/AlgorithmIdentifier.hs @@ -28,24 +28,36 @@ -- | 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_ECDSA -- ^ ECDSA 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 +-- | 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_DSA = [1,2,840,10040,4,1] - getObjectID PubKeyALG_ECDSA = [1,2,840,10045,2,1] - getObjectID PubKeyALG_DH = [1,2,840,10046,2,1] + 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) ] @@ -55,11 +67,22 @@ , ([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,3,1], SignatureALG HashSHA224 PubKeyALG_ECDSA) - , ([1,2,840,10045,4,3,2], SignatureALG HashSHA256 PubKeyALG_ECDSA) - , ([1,2,840,10045,4,3,3], SignatureALG HashSHA384 PubKeyALG_ECDSA) - , ([1,2,840,10045,4,3,4], SignatureALG HashSHA512 PubKeyALG_ECDSA) + , ([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 @@ -69,11 +92,29 @@ 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) = - Right (oidSig oid, 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 --- a/Data/X509/CRL.hs +++ b/Data/X509/CRL.hs @@ -17,9 +17,8 @@ ) where import Control.Applicative -import Control.Monad.Error -import Data.Time.Clock (UTCTime) +import Data.Hourglass (DateTime, TimezoneOffset(..)) import Data.ASN1.Types import Data.X509.DistinguishedName @@ -32,8 +31,8 @@ { crlVersion :: Integer , crlSignatureAlg :: SignatureALG , crlIssuer :: DistinguishedName - , crlThisUpdate :: UTCTime - , crlNextUpdate :: Maybe UTCTime + , crlThisUpdate :: DateTime + , crlNextUpdate :: Maybe DateTime , crlRevokedCertificates :: [RevokedCertificate] , crlExtensions :: Extensions } deriving (Show,Eq) @@ -41,7 +40,7 @@ -- | Describe a revoked certificate identifiable by serial number. data RevokedCertificate = RevokedCertificate { revokedSerialNumber :: Integer - , revokedDate :: UTCTime + , revokedDate :: DateTime , revokedExtensions :: Extensions } deriving (Show,Eq) @@ -49,14 +48,30 @@ toASN1 crl = encodeCRL crl fromASN1 = runParseASN1State parseCRL --- TODO support extension instance ASN1Object RevokedCertificate where - fromASN1 (Start Sequence : IntVal serial : ASN1Time _ t _ : End Sequence : xs) = - Right (RevokedCertificate serial t (Extensions Nothing), xs) - fromASN1 l = Left ("fromASN1: X509.RevokedCertificate: unknown format:" ++ show l) - toASN1 (RevokedCertificate serial time _) = \xs -> - Start Sequence : IntVal serial : ASN1Time TimeGeneralized time Nothing : End Sequence : xs + 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) @@ -64,32 +79,41 @@ <*> getObject <*> (getNext >>= getThisUpdate) <*> getNextUpdate - <*> getRevokedCertificates - <*> getObject + <*> parseRevokedCertificates + <*> parseCRLExtensions where getVersion (IntVal v) = return $ fromIntegral v - getVersion _ = throwError "unexpected type for version" + getVersion _ = throwParseError "unexpected type for version" getThisUpdate (ASN1Time _ t1 _) = return t1 - getThisUpdate _ = throwError "bad this update format, expecting time" + getThisUpdate _ = throwParseError "bad this update format, expecting time" getNextUpdate = getNextMaybe timeOrNothing timeOrNothing (ASN1Time _ tnext _) = Just tnext timeOrNothing _ = Nothing - getRevokedCertificates = onNextContainer Sequence $ getMany getObject +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) Nothing] ++ - (maybe [] (\t -> [ASN1Time TimeGeneralized t Nothing]) (crlNextUpdate crl)) ++ - [Start Sequence] ++ - revoked ++ - [End Sequence] ++ - toASN1 (crlExtensions 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 - revoked = concatMap (\e -> toASN1 e []) (crlRevokedCertificates crl) + 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 --- a/Data/X509/Cert.hs +++ b/Data/X509/Cert.hs @@ -12,14 +12,13 @@ module Data.X509.Cert (Certificate(..)) where import Data.ASN1.Types -import Data.Time.Clock (UTCTime) import Control.Applicative ((<$>), (<*>)) -import Control.Monad.Error 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 @@ -42,7 +41,7 @@ , certSerial :: Integer -- ^ Serial number , certSignatureAlg :: SignatureALG -- ^ Signature algorithm , certIssuerDN :: DistinguishedName -- ^ Issuer DN - , certValidity :: (UTCTime, UTCTime) -- ^ Validity period + , certValidity :: (DateTime, DateTime) -- ^ Validity period (UTC) , certSubjectDN :: DistinguishedName -- ^ Subject DN , certPubKey :: PubKey -- ^ Public key , certExtensions :: Extensions -- ^ Extensions @@ -54,21 +53,21 @@ parseCertHeaderVersion :: ParseASN1 Int parseCertHeaderVersion = - maybe 1 id <$> onNextContainerMaybe (Container Context 0) (getNext >>= getVer) + maybe 0 id <$> onNextContainerMaybe (Container Context 0) (getNext >>= getVer) where getVer (IntVal v) = return $ fromIntegral v - getVer _ = throwError "unexpected type for version" + getVer _ = throwParseError "unexpected type for version" parseCertHeaderSerial :: ParseASN1 Integer parseCertHeaderSerial = do n <- getNext case n of IntVal v -> return v - _ -> throwError ("missing serial" ++ show n) + _ -> throwParseError ("missing serial" ++ show n) -parseCertHeaderValidity :: ParseASN1 (UTCTime, UTCTime) +parseCertHeaderValidity :: ParseASN1 (DateTime, DateTime) parseCertHeaderValidity = getNextContainer Sequence >>= toTimeBound where toTimeBound [ ASN1Time _ t1 _, ASN1Time _ t2 _ ] = return (t1,t2) - toTimeBound _ = throwError "bad validity format" + toTimeBound _ = throwParseError "bad validity format" {- | parse header structure of a x509 certificate. the structure is the following: Version @@ -86,6 +85,12 @@ 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 @@ -95,7 +100,7 @@ <*> parseCertHeaderValidity <*> getObject <*> getObject - <*> getObject + <*> parseExtensions encodeCertificateHeader :: Certificate -> [ASN1] encodeCertificateHeader cert = @@ -105,8 +110,14 @@ eAlgId = toASN1 (certSignatureAlg cert) [] eIssuer = toASN1 (certIssuerDN cert) [] (t1, t2) = certValidity cert - eValidity = asn1Container Sequence [ASN1Time TimeGeneralized t1 Nothing - ,ASN1Time TimeGeneralized t2 Nothing] + 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 = toASN1 (certExtensions 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/DistinguishedName.hs b/Data/X509/DistinguishedName.hs --- a/Data/X509/DistinguishedName.hs +++ b/Data/X509/DistinguishedName.hs @@ -6,6 +6,8 @@ -- Portability : unknown -- -- X.509 Distinguished names types and functions + +{-# LANGUAGE CPP #-} module Data.X509.DistinguishedName ( DistinguishedName(..) , DistinguishedNameInner(..) @@ -16,10 +18,13 @@ ) where import Control.Applicative -import Data.Monoid +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +#else +import Data.Monoid +#endif import Data.ASN1.Types import Data.X509.Internal -import Control.Monad.Error -- | A list of OID and strings. newtype DistinguishedName = DistinguishedName { getDistinguishedElements :: [(OID, ASN1CharacterString)] } @@ -31,6 +36,7 @@ | DnCountry -- ^ Country | DnOrganization -- ^ O | DnOrganizationUnit -- ^ OU + | DnEmailAddress -- ^ Email Address (legacy) deriving (Show,Eq) instance OIDable DnElement where @@ -38,6 +44,7 @@ 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 @@ -48,9 +55,16 @@ 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 @@ -73,7 +87,7 @@ s <- getNextContainer Sequence case s of [OID oid, ASN1String cs] -> return (oid, cs) - _ -> throwError ("expecting [OID,String] got " ++ show s) + _ -> throwParseError ("expecting [OID,String] got " ++ show s) encodeDNinner :: DistinguishedName -> [ASN1] encodeDNinner (DistinguishedName dn) = concatMap dnSet 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 --- a/Data/X509/Ext.hs +++ b/Data/X509/Ext.hs @@ -8,7 +8,7 @@ -- extension processing module. -- {-# LANGUAGE FlexibleContexts #-} - +{-# LANGUAGE ScopedTypeVariables #-} module Data.X509.Ext ( Extension(..) -- * Common extension usually found in x509v3 @@ -21,6 +21,7 @@ , ExtSubjectAltName(..) , ExtAuthorityKeyId(..) , ExtCrlDistributionPoints(..) + , ExtNetscapeComment(..) , AltName(..) , DistributionPoint(..) , ReasonFlag(..) @@ -35,12 +36,15 @@ 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.Error +import Control.Monad -- | key usage flag that is found in the key usage extension field. data ExtKeyUsageFlag = @@ -66,11 +70,24 @@ -- -- 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 - extEncode :: a -> [ASN1] - extDecode :: [ASN1] -> Either String a + 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 @@ -95,16 +112,17 @@ -- * 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 :: Extension a => ExtensionRaw -> Maybe (Either String a) -extensionDecode = doDecode undefined - where doDecode :: Extension a => a -> ExtensionRaw -> Maybe (Either String a) - doDecode dummy (ExtensionRaw oid _ asn1) - | extOID dummy == oid = Just (extDecode asn1) - | otherwise = Nothing +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 :: Extension a => Bool -> a -> ExtensionRaw -extensionEncode critical ext = ExtensionRaw (extOID ext) critical (extEncode ext) +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) @@ -112,6 +130,7 @@ 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] @@ -128,6 +147,7 @@ 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" @@ -159,6 +179,7 @@ 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 @@ -175,6 +196,7 @@ 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" @@ -204,6 +226,7 @@ instance Extension ExtSubjectAltName where extOID = const [2,5,29,17] + extHasNestedASN1 = const True extEncode (ExtSubjectAltName names) = encodeGeneralNames names extDecode l = runParseASN1 (ExtSubjectAltName <$> parseGeneralNames) l @@ -214,6 +237,7 @@ 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] = @@ -245,6 +269,7 @@ instance Extension ExtCrlDistributionPoints where extOID _ = [2,5,29,31] + extHasNestedASN1 = const True extEncode = error "extEncode ExtCrlDistributionPoints unimplemented" extDecode = error "extDecode ExtCrlDistributionPoints unimplemented" --extEncode (ExtCrlDistributionPoints ) @@ -265,19 +290,19 @@ case c of Just [ASN1String cs] -> case asn1CharacterToString cs of - Nothing -> throwError ("GeneralNames: invalid string for XMPP Addr") + Nothing -> throwParseError ("GeneralNames: invalid string for XMPP Addr") Just s -> return $ AltNameXMPP s - _ -> throwError ("GeneralNames: expecting string for XMPP Addr got: " ++ show c) + _ -> 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 -> throwError ("GeneralNames: invalid string for DNSSrv Addr") + Nothing -> throwParseError ("GeneralNames: invalid string for DNSSrv Addr") Just s -> return $ AltNameDNSSRV s - _ -> throwError ("GeneralNames: expecting string for DNSSRV Addr got: " ++ show c) - OID unknown -> throwError ("GeneralNames: unknown OID " ++ show unknown) - _ -> throwError ("GeneralNames: expecting OID but got " ++ show n) + _ -> 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 @@ -286,7 +311,7 @@ (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 - _ -> throwError ("GeneralNames: not coping with unknown stream " ++ show n) + _ -> throwParseError ("GeneralNames: not coping with unknown stream " ++ show n) encodeGeneralNames :: [AltName] -> [ASN1] encodeGeneralNames names = @@ -312,3 +337,14 @@ 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 --- a/Data/X509/ExtensionRaw.hs +++ b/Data/X509/ExtensionRaw.hs @@ -9,6 +9,8 @@ -- module Data.X509.ExtensionRaw ( ExtensionRaw(..) + , tryExtRawASN1 + , extRawASN1 , Extensions(..) ) where @@ -17,14 +19,25 @@ 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 - , extRawASN1 :: [ASN1] -- ^ the associated ASN1 + , 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) @@ -32,28 +45,20 @@ instance ASN1Object Extensions where toASN1 (Extensions Nothing) = \xs -> xs toASN1 (Extensions (Just exts)) = \xs -> - asn1Container (Container Context 3) (asn1Container Sequence (concatMap encodeExt exts)) ++ xs + asn1Container Sequence (concatMap encodeExt exts) ++ xs fromASN1 s = runParseASN1State (Extensions <$> parseExtensions) s - where parseExtensions = onNextContainerMaybe (Container Context 3) $ - onNextContainer Sequence (getMany getObject) + 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 -> extractExt b obj xs2 - OctetString obj:End Sequence:xs2 -> extractExt False obj xs2 + 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) - where - extractExt critical bs remainingStream = - case decodeASN1' BER bs of - Left err -> Left ("fromASN1: X509.ExtensionRaw: OID=" ++ show oid ++ - ": cannot decode data: " ++ show err) - Right r -> Right (ExtensionRaw oid critical r, remainingStream) fromASN1 l = Left ("fromASN1: X509.ExtensionRaw: unknown format:" ++ show l) encodeExt :: ExtensionRaw -> [ASN1] -encodeExt (ExtensionRaw oid critical asn1) = - let bs = encodeASN1' DER asn1 - in asn1Container Sequence ([OID oid] ++ (if critical then [Boolean True] else []) ++ [OctetString bs]) +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 --- a/Data/X509/Internal.hs +++ b/Data/X509/Internal.hs @@ -9,10 +9,18 @@ ( 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] 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 --- a/Data/X509/PrivateKey.hs +++ b/Data/X509/PrivateKey.hs @@ -5,24 +5,288 @@ -- Stability : experimental -- Portability : unknown -- --- Public key handling in X.509 infrastructure +-- 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 qualified Crypto.Types.PubKey.RSA as RSA -import qualified Crypto.Types.PubKey.DSA as DSA +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) --- | Convert a Public key to the Public Key Algorithm type +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 --- a/Data/X509/PublicKey.hs +++ b/Data/X509/PublicKey.hs @@ -9,6 +9,8 @@ -- module Data.X509.PublicKey ( PubKey(..) + , PubKeyEC(..) + , SerializedPoint(..) , pubkeyToAlg ) where @@ -17,23 +19,63 @@ 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 qualified Crypto.Types.PubKey.RSA as RSA -import qualified Crypto.Types.PubKey.DSA as DSA -import qualified Crypto.Types.PubKey.ECC as ECC +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)) - | PubKeyECDSA ECC.CurveName B.ByteString + | 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) @@ -48,7 +90,7 @@ 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 . fromASN1) + 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 @@ -64,14 +106,60 @@ _ -> Left "fromASN1: X509.PubKey: unknown DSA format" ) _ -> Left "fromASN1: X509.PubKey: unknown DSA format" - | pkalg == getObjectID PubKeyALG_ECDSA = + | pkalg == getObjectID PubKeyALG_EC = case xs of OID curveOid:End Sequence:BitString bits:End Sequence:xs2 -> - case fromObjectID curveOid of - Just curveName -> Right (PubKeyECDSA curveName (bitArrayGetData bits), xs2) - Nothing -> Left ("fromASN1: X509.Pubkey: ECDSA unknown curve " ++ show curveOid) - _ -> Left "fromASN1: X509.PubKey: unknown ECDSA format" - | otherwise = error ("unknown public key OID: " ++ show pkalg) + 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) @@ -80,9 +168,15 @@ Right (r, xsinner) -> Right (r, xsinner ++ xs2) toPubKeyRSA = either Left (\(rsaKey, r) -> Right (PubKeyRSA rsaKey, r)) - removeNull (Null:xs) = xs - removeNull l = l + 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 @@ -91,7 +185,11 @@ pubkeyToAlg (PubKeyRSA _) = PubKeyALG_RSA pubkeyToAlg (PubKeyDSA _) = PubKeyALG_DSA pubkeyToAlg (PubKeyDH _) = PubKeyALG_DH -pubkeyToAlg (PubKeyECDSA _ _) = PubKeyALG_ECDSA +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] @@ -100,7 +198,7 @@ pkalg = OID $ getObjectID $ pubkeyToAlg key encodeInner (PubKeyRSA pubkey) = asn1Container Sequence [pkalg,Null] ++ [BitString $ toBitArray bits 0] - where bits = encodeASN1' DER $ asn1Container Sequence [IntVal (RSA.public_n pubkey), IntVal (RSA.public_e pubkey)] + where bits = encodeASN1' DER $ rsaPubToASN1 pubkey [] encodeInner (PubKeyDSA pubkey) = asn1Container Sequence ([pkalg] ++ dsaseq) ++ [BitString $ toBitArray bits 0] where @@ -109,12 +207,73 @@ ,IntVal (DSA.params_g params)] params = DSA.public_params pubkey bits = encodeASN1' DER [IntVal $ DSA.public_y pubkey] - encodeInner (PubKeyECDSA curveName bits) = + encodeInner (PubKeyEC (PubKeyEC_Named curveName (SerializedPoint bits))) = asn1Container Sequence [pkalg,OID eOid] ++ [BitString $ toBitArray bits 0] where - eOid = case curveName of - ECC.SEC_p384r1 -> [1,3,132,0,34] - _ -> error ("undefined curve OID: " ++ show curveName) + 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 --- a/Data/X509/Signed.hs +++ b/Data/X509/Signed.hs @@ -35,6 +35,7 @@ , decodeSignedObject -- * Object to Signed and SignedExact , objectToSignedExact + , objectToSignedExactF , objectToSigned , signedToExact ) where @@ -93,21 +94,34 @@ => (ByteString -> (ByteString, SignatureALG, r)) -- ^ signature function -> a -- ^ object to sign -> (SignedExact a, r) -objectToSignedExact signatureFunction object = (SignedExact signed objRaw signedRaw, r) - where signed = Signed { signedObject = object - , signedAlg = sigAlg - , signedSignature = sigBits - } - signedRaw = encodeASN1' DER signedASN1 - signedASN1 = Start Sequence - : objASN1 - (toASN1 sigAlg - (BitString (toBitArray sigBits 0) - : End Sequence - : [])) +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 []) - (sigBits,sigAlg,r) = signatureFunction objRaw -- | Transform an object into a 'Signed' object. -- diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -1,10 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Main where -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) - -import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck import qualified Data.ByteString as B @@ -14,11 +12,15 @@ import Data.List (nub, sort) import Data.ASN1.Types import Data.X509 -import qualified Crypto.Types.PubKey.RSA as RSA -import qualified Crypto.Types.PubKey.DSA as DSA +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.Time.Clock -import Data.Time.Clock.POSIX +import Data.Hourglass instance Arbitrary RSA.PublicKey where arbitrary = do @@ -36,18 +38,69 @@ 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_ECDSA,PubKeyALG_DH] + 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, @@ -59,11 +112,17 @@ , 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_ECDSA - , SignatureALG HashSHA256 PubKeyALG_ECDSA - , SignatureALG HashSHA384 PubKeyALG_ECDSA - , SignatureALG HashSHA512 PubKeyALG_ECDSA + , 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) @@ -78,8 +137,10 @@ arbitrary = DistinguishedName <$> (choose (1,5) >>= \l -> replicateM l arbitraryDE) where arbitraryDE = (,) <$> arbitrary <*> arbitrary -instance Arbitrary UTCTime where - arbitrary = posixSecondsToUTCTime . fromIntegral <$> (arbitrary :: Gen Int) +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 @@ -118,7 +179,7 @@ instance Arbitrary RevokedCertificate where arbitrary = RevokedCertificate <$> arbitrary <*> arbitrary - <*> pure (Extensions Nothing) + <*> arbitrary instance Arbitrary CRL where arbitrary = CRL <$> pure 1 @@ -146,9 +207,10 @@ Right v | v == e -> True | otherwise -> error ("expected " ++ show e ++ " got: " ++ show v) -main = defaultMain +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) diff --git a/x509.cabal b/x509.cabal --- a/x509.cabal +++ b/x509.cabal @@ -1,6 +1,6 @@ Name: x509 -Version: 1.4.13 -Description: X509 reader and writer +version: 1.7.7 +Description: X509 reader and writer. please see README License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez @@ -11,24 +11,24 @@ Category: Data stability: experimental Homepage: http://github.com/vincenthz/hs-certificate -Cabal-Version: >=1.8 +Cabal-Version: >= 1.10 +Extra-Source-Files: ChangeLog.md Library - Build-Depends: base >= 3 && < 5 + Default-Language: Haskell2010 + Build-Depends: base >= 4.7 && < 5 , bytestring - , mtl + , memory + , transformers >= 0.4 , containers - , directory - , filepath - , process - , time - , pem >= 0.1 && < 0.3 - , asn1-types >= 0.2.3 && < 0.3 - , asn1-encoding >= 0.8 && < 0.9 - , asn1-parse >= 0.8 && < 0.9 - , crypto-pubkey-types >= 0.4.2.1 && < 0.5 - , cryptohash >= 0.9 && < 0.12 + , hourglass + , pem >= 0.1 + , asn1-types >= 0.3.1 && < 0.4 + , asn1-encoding >= 0.9 && < 0.10 + , asn1-parse >= 0.9.3 && < 0.10 + , cryptonite >= 0.24 Exposed-modules: Data.X509 + Data.X509.EC Other-modules: Data.X509.Internal Data.X509.CertificateChain Data.X509.AlgorithmIdentifier @@ -39,25 +39,24 @@ 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 - , QuickCheck >= 2 - , HUnit - , test-framework - , test-framework-quickcheck2 - , test-framework-hunit - , time + , tasty + , tasty-quickcheck + , hourglass , asn1-types , x509 - , crypto-pubkey-types + , cryptonite ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures source-repository head