crypton-x509 1.10.0 → 1.10.1
raw patch · 8 files changed
+290/−60 lines, 8 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +9/−0
- Data/X509/Ext.hs +81/−52
- Data/X509/ExtensionRaw.hs +2/−2
- Data/X509/Internal.hs +43/−0
- Data/X509/PublicKey.hs +4/−4
- Data/X509/Signed.hs +2/−1
- Tests/Tests.hs +148/−0
- crypton-x509.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,14 @@ # ChangeLog for crypton-x509 +## 1.10.1++* Decoding functions return `Left` instead of throwing on malformed+ input (lazy decoder errors, unknown key usage bits, non-OID extended+ key usage, CRL distribution points, invalid strings).+* Fix the encoding of NameConstraints, which its own decoder could not+ read, and of directoryName and dNSSRV GeneralNames.+* SubjectAltName decoding skips unsupported GeneralName types.+ ## 1.10.0 * Support ML-DSA (RFC 9881)
Data/X509/Ext.hs view
@@ -43,12 +43,15 @@ import Data.ASN1.Encoding import Data.ASN1.Parse import Data.ASN1.Types+import Data.Bits (shiftR, testBit, (.&.)) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.List (find)+import Data.Maybe (catMaybes) import Data.Proxy import Data.X509.DistinguishedName import Data.X509.ExtensionRaw+import Data.X509.Internal (safeCharacterToString, safeDecode) -- | key usage flag that is found in the key usage extension field. data ExtKeyUsageFlag@@ -86,7 +89,7 @@ extDecode :: [ASN1] -> Either String a extDecodeBs :: B.ByteString -> Either String a- extDecodeBs = (either (Left . show) Right . decodeASN1' BER) >=> extDecode+ extDecodeBs = (safeDecode . decodeASN1' BER) >=> extDecode extEncodeBs :: a -> B.ByteString extEncodeBs = encodeASN1' DER . extEncode@@ -157,7 +160,8 @@ extOID = const [2, 5, 29, 15] extHasNestedASN1 = const True extEncode (ExtKeyUsage flags) = [BitString $ flagsToBits flags]- extDecode [BitString bits] = Right $ ExtKeyUsage $ bitsToFlags bits+ extDecode [BitString bits] =+ Right $ ExtKeyUsage $ bitsToFlags KeyUsage_decipherOnly bits extDecode _ = Left "unknown sequence" -- | Key usage purposes for the ExtendedKeyUsage extension@@ -204,7 +208,7 @@ case n of OID o -> return $ maybe (KeyUsagePurpose_Unknown o) id $ lookup o extKeyUsagePurposedOID- _ -> error "invalid content in extended key usage"+ _ -> throwParseError "invalid content in extended key usage" ) -- | Provide a way to identify a public key by a short hash.@@ -287,19 +291,31 @@ extOID _ = [2, 5, 29, 31] extHasNestedASN1 = const True extEncode = error "extEncode ExtCrlDistributionPoints unimplemented"- extDecode = error "extDecode ExtCrlDistributionPoints unimplemented"+ extDecode _ = Left "extDecode ExtCrlDistributionPoints unimplemented" -- extEncode (ExtCrlDistributionPoints ) +-- | GeneralName types that 'AltName' cannot represent are skipped. parseGeneralNames :: ParseASN1 [AltName]-parseGeneralNames = onNextContainer Sequence $ getMany getAddr+parseGeneralNames = onNextContainer Sequence $ catMaybes <$> getMany getAddrMaybe +-- | Fails on GeneralName types that 'AltName' cannot represent. getAddr :: ParseASN1 AltName-getAddr = do+getAddr =+ getAddrMaybe+ >>= maybe (throwParseError "GeneralNames: unsupported name type") return++-- | 'Nothing' for a well-formed GeneralName of an unsupported type.+getAddrMaybe :: ParseASN1 (Maybe AltName)+getAddrMaybe = do m <- onNextContainerMaybe (Container Context 0) getComposedAddr case m of- Nothing -> getSimpleAddr Just r -> return r+ Nothing -> do+ d <- onNextContainerMaybe (Container Context 4) getObject+ case d of+ Just dn -> return $ Just $ AltNameDN dn+ Nothing -> getUnsupportedOrSimpleAddr where getComposedAddr = do n <- getNext@@ -309,9 +325,9 @@ c <- getNextContainerMaybe (Container Context 0) case c of Just [ASN1String cs] ->- case asn1CharacterToString cs of+ case safeCharacterToString cs of Nothing -> throwParseError ("GeneralNames: invalid string for XMPP Addr")- Just s -> return $ AltNameXMPP s+ Just s -> return $ Just $ AltNameXMPP s _ -> throwParseError ("GeneralNames: expecting string for XMPP Addr got: " ++ show c) OID [1, 3, 6, 1, 5, 5, 7, 8, 7] -> do@@ -319,29 +335,36 @@ c <- getNextContainerMaybe (Container Context 0) case c of Just [ASN1String cs] ->- case asn1CharacterToString cs of+ case safeCharacterToString cs of Nothing -> throwParseError ("GeneralNames: invalid string for DNSSrv Addr")- Just s -> return $ AltNameDNSSRV s+ Just s -> return $ Just $ AltNameDNSSRV s _ -> throwParseError ("GeneralNames: expecting string for DNSSRV Addr got: " ++ show c)- OID unknown -> throwParseError ("GeneralNames: unknown OID " ++ show unknown)+ OID _ -> getMany getNext >> return Nothing -- unknown otherName _ -> 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 4 b) -> case decodeASN1' DER b of- Left e1 -> throwParseError $ show e1+ (Other Context 1 b) -> return $ Just $ AltNameRFC822 $ BC.unpack b+ (Other Context 2 b) -> return $ Just $ AltNameDNS $ BC.unpack b+ -- directoryName as written by older versions of this library+ (Other Context 4 b) -> case safeDecode (decodeASN1' DER b) of+ Left e1 -> throwParseError e1 Right as -> case runParseASN1 getObject as of- Right dn -> return $ AltNameDN dn+ Right dn -> return $ Just $ AltNameDN dn Left e2 -> throwParseError e2- (Other Context 6 b) -> return $ AltNameURI $ BC.unpack b- (Other Context 7 b) -> return $ AltNameIP b+ (Other Context 6 b) -> return $ Just $ AltNameURI $ BC.unpack b+ (Other Context 7 b) -> return $ Just $ AltNameIP b+ (Other Context 8 _) -> return Nothing -- registeredID _ -> throwParseError ("GeneralNames: not coping with unknown stream " ++ show n)+ -- x400Address and ediPartyName are skipped+ getUnsupportedOrSimpleAddr = do+ x400 <- getNextContainerMaybe (Container Context 3)+ edi <- maybe (getNextContainerMaybe (Container Context 5)) (return . Just) x400+ maybe getSimpleAddr (const $ return Nothing) edi encodeGeneralNames :: [AltName] -> [ASN1] encodeGeneralNames names =@@ -352,7 +375,8 @@ encodeAltName :: AltName -> [ASN1] encodeAltName (AltNameRFC822 n) = [Other Context 1 $ BC.pack n] encodeAltName (AltNameDNS n) = [Other Context 2 $ BC.pack n]-encodeAltName (AltNameDN dn) = [Other Context 4 $ encodeASN1' DER $ toASN1 dn []]+encodeAltName (AltNameDN dn) =+ [Start (Container Context 4)] ++ toASN1 dn [End (Container Context 4)] encodeAltName (AltNameURI n) = [Other Context 6 $ BC.pack n] encodeAltName (AltNameIP n) = [Other Context 7 $ n] encodeAltName (AltNameXMPP n) =@@ -365,17 +389,21 @@ ] encodeAltName (AltNameDNSSRV n) = [ Start (Container Context 0)- , OID [1, 3, 6, 1, 5, 5, 7, 8, 5]+ , OID [1, 3, 6, 1, 5, 5, 7, 8, 7] , 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 []+-- | Bits beyond the last known flag (the first argument) or beyond the+-- actual data (a bogus length) are ignored.+bitsToFlags :: Enum a => a -> BitArray -> [a]+bitsToFlags lastFlag bits =+ [toEnum (fromIntegral i) | len > 0, i <- [0 .. len - 1], bitArrayGetBit bits i]+ where+ dataLen = 8 * fromIntegral (B.length (bitArrayGetData bits))+ len = minimum [bitArrayLength bits, dataLen, fromIntegral (fromEnum lastFlag) + 1] flagsToBits :: Enum a => [a] -> BitArray flagsToBits flags = foldl bitArraySetBit bitArrayEmpty $ map (fromIntegral . fromEnum) flags@@ -434,26 +462,26 @@ ++ [End Sequence] where put _ [] = []+ -- IMPLICIT tagging: the tag replaces the SEQUENCE OF put n xs =- [Start (Container Context n), Start Sequence]+ [Start (Container Context n)] ++ concatMap encodeGeneralSubtree xs- ++ [End Sequence, End (Container Context n)]+ ++ [End (Container Context n)] encodeGeneralSubtree :: GeneralSubtree -> [ASN1] encodeGeneralSubtree (GeneralSubtree base minimum' maximum') = [Start Sequence] ++ encodeAltName base- ++ ( if minimum' /= 0- then [Other Context 0 (encodeASN1' DER [IntVal minimum'])]- else []- )- ++ maybe- []- ( \m ->- [Other Context 1 (encodeASN1' DER [IntVal m])]- )- maximum'+ ++ (if minimum' /= 0 then [Other Context 0 (intContent minimum')] else [])+ ++ maybe [] (\m -> [Other Context 1 (intContent m)]) maximum' ++ [End Sequence]+ where+ -- the content octets of an IMPLICIT INTEGER (two's complement)+ intContent = B.pack . go+ where+ go i+ | i >= -128 && i < 128 = [fromIntegral i]+ | otherwise = go (i `shiftR` 8) ++ [fromIntegral (i .&. 0xff)] -------------------------------------------------------------------------------- -- Decoding@@ -476,6 +504,8 @@ decodeSubtrees :: [ASN1] -> Either String ([GeneralSubtree], [ASN1]) decodeSubtrees ys = loop ys [] where+ loop (End (Container Context _) : _) [] =+ Left "NameConstraints: empty GeneralSubtrees" loop (End (Container Context _) : rest) acc = Right (reverse acc, rest) loop zs acc = do@@ -490,21 +520,12 @@ decodeGeneralSubtree (Start Sequence : xs) = do (base, rest1) <- runParseASN1State getAddr xs - let (minimum', rest2) =- case rest1 of- (Other Context 0 bs : rs) ->- case decodeASN1' DER bs of- Right [IntVal n] -> (n, rs)- _ -> (0, rest1)- _ -> (0, rest1)-- let (maximum', rest3) =- case rest2 of- (Other Context 1 bs : rs) ->- case decodeASN1' DER bs of- Right [IntVal n] -> (Just n, rs)- _ -> (Nothing, rest2)- _ -> (Nothing, rest2)+ (minimum', rest2) <- case rest1 of+ (Other Context 0 bs : rs) -> (\n -> (n, rs)) <$> implicitInt bs+ _ -> Right (0, rest1)+ (maximum', rest3) <- case rest2 of+ (Other Context 1 bs : rs) -> (\n -> (Just n, rs)) <$> implicitInt bs+ _ -> Right (Nothing, rest2) case rest3 of (End Sequence : rs) ->@@ -513,6 +534,14 @@ Left "GeneralSubtree: missing end sequence" decodeGeneralSubtree _ = Left "GeneralSubtree: invalid ASN1"++-- | Decode the content octets of an IMPLICIT INTEGER.+implicitInt :: B.ByteString -> Either String Integer+implicitInt bs+ | B.null bs = Left "GeneralSubtree: empty integer"+ | otherwise = Right $ B.foldl' (\a w -> a * 256 + fromIntegral w) sign bs+ where+ sign = if testBit (B.head bs) 7 then -1 else 0 recognizedOIDs :: [OID] recognizedOIDs =
Data/X509/ExtensionRaw.hs view
@@ -32,13 +32,13 @@ tryExtRawASN1 :: ExtensionRaw -> Either String [ASN1] tryExtRawASN1 (ExtensionRaw oid _ content) =- case decodeASN1' BER content of+ case safeDecode (decodeASN1' BER content) of Left err -> Left $ "fromASN1: X509.ExtensionRaw: OID=" ++ show oid ++ ": cannot decode data: "- ++ show err+ ++ err Right r -> Right r extRawASN1 :: ExtensionRaw -> [ASN1]
Data/X509/Internal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- Module : Data.X509.Internal -- License : BSD-style@@ -12,11 +14,23 @@ -- * error handling ErrT, runErrT,+ safeDecode,+ safeCharacterToString, ) where +import Control.Exception (+ SomeAsyncException,+ SomeException,+ evaluate,+ fromException,+ throwIO,+ try,+ ) import Control.Monad.Trans.Except import Data.ASN1.Parse import Data.ASN1.Types+import qualified Data.List as L+import System.IO.Unsafe (unsafeDupablePerformIO) runErrT :: ExceptT e m a -> m (Either e a) runErrT = runExceptT@@ -25,3 +39,32 @@ -- | create a container around the stream of ASN1 asn1Container :: ASN1ConstructionType -> [ASN1] -> [ASN1] asn1Container ty l = [Start ty] ++ l ++ [End ty]++-- | Force a decoded ASN.1 stream so that errors thrown lazily from inside+-- the list by the decoder are turned into 'Left'.+safeDecode :: Show e => Either e [a] -> Either String [a]+safeDecode r = case tryPure forceE r of+ Left err -> Left err+ Right (Left e) -> Left (show e)+ Right (Right xs) -> Right xs+ where+ forceE (Left e) = length (show e) `seq` ()+ forceE (Right xs) = L.foldl' (flip seq) () xs++-- | Like 'asn1CharacterToString' but 'Nothing' on invalid encoding.+safeCharacterToString :: ASN1CharacterString -> Maybe String+safeCharacterToString cs =+ asn1CharacterToString cs >>= either (const Nothing) Just . tryPure force+ where+ force = L.foldl' (flip seq) ()++-- | Run a forcing function and turn synchronous exceptions into 'Left'.+tryPure :: (a -> ()) -> a -> Either String a+tryPure force x = unsafeDupablePerformIO $ do+ res <- try $ evaluate $ force x+ case res of+ Right () -> return $ Right x+ Left (e :: SomeException)+ | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e+ | otherwise -> return $ Left (show e)+{-# NOINLINE tryPure #-}
Data/X509/PublicKey.hs view
@@ -206,10 +206,10 @@ | otherwise = Left $ "fromASN1: unknown public key OID: " ++ show pkalg where decodeASN1Err format bits xs2 f =- case decodeASN1' BER (bitArrayGetData bits) of+ case safeDecode (decodeASN1' BER (bitArrayGetData bits)) of Left err -> Left- ("fromASN1: X509.PubKey " ++ format ++ " bitarray cannot be parsed: " ++ show err)+ ("fromASN1: X509.PubKey " ++ format ++ " bitarray cannot be parsed: " ++ err) Right s -> case f s of Left err -> Left err Right (r, xsinner) -> Right (r, xsinner ++ xs2)@@ -328,8 +328,8 @@ | 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+ let inner = either strError rsaPubFromASN1 $ safeDecode $ decodeASN1' BER bs+ strError = Left . ("fromASN1: RSA.PublicKey: " ++) in either Left (\(k, _) -> Right (k, xs)) inner rsaPubFromASN1 _ = Left "fromASN1: RSA.PublicKey: unexpected format"
Data/X509/Signed.hs view
@@ -51,6 +51,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.X509.AlgorithmIdentifier+import Data.X509.Internal (safeDecode) -- | Represent a signed object using a traditional X509 structure. --@@ -165,7 +166,7 @@ :: (Show a, Eq a, ASN1Object a) => ByteString -> Either String (SignedExact a)-decodeSignedObject b = either (Left . show) parseSigned $ decodeASN1Repr' BER b+decodeSignedObject b = either Left parseSigned $ safeDecode $ decodeASN1Repr' BER b where -- the following implementation is very inefficient. -- uses reverse and containing, move to a better solution eventually
Tests/Tests.hs view
@@ -20,10 +20,12 @@ import qualified Crypto.PubKey.MLDSA as MLDSA import qualified Crypto.PubKey.RSA as RSA import Data.ASN1.BinaryEncoding (DER (..))+import Data.ASN1.BitArray (toBitArray) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.Types import Data.ByteArray (convert) import Data.List (isInfixOf, nub, sort)+import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.X509 @@ -452,6 +454,138 @@ , End Sequence ] +instance Arbitrary AltName where+ arbitrary =+ oneof+ [ AltNameDNS <$> arbitraryHost+ , AltNameRFC822 . ("user@" ++) <$> arbitraryHost+ , AltNameURI . ("https://" ++) <$> arbitraryHost+ , AltNameIP . B.pack <$> (elements [4, 8, 16, 32] >>= vector)+ , AltNameDN <$> arbitrary+ ]+ where+ arbitraryHost = listOf1 (elements "abcxyz.-")++instance Arbitrary GeneralSubtree where+ arbitrary =+ GeneralSubtree+ <$> arbitrary+ <*> pure 0+ <*> oneof [pure Nothing, Just <$> choose (0, 300)]++instance Arbitrary ExtNameConstraints where+ arbitrary = ExtNameConstraints <$> arbitrary <*> arbitrary++instance Arbitrary ExtSubjectAltName where+ arbitrary = ExtSubjectAltName <$> arbitrary++-- NameConstraints with permitted dNSName "example.com" and+-- excluded iPAddress 10.0.0.0/8, as encoded by OpenSSL.+property_name_constraints_der :: Bool+property_name_constraints_der =+ extensionDecode raw+ == Just+ ( Right $+ ExtNameConstraints+ [GeneralSubtree (AltNameDNS "example.com") 0 Nothing]+ [GeneralSubtree (AltNameIP (B.pack [10, 0, 0, 0, 255, 0, 0, 0])) 0 Nothing]+ )+ && extensionEncode+ True+ (either error id (fromJust (extensionDecode raw)) :: ExtNameConstraints)+ == raw+ where+ raw = ExtensionRaw [2, 5, 29, 30] True der+ der =+ B.pack $+ [0x30, 0x1f, 0xa0, 0x0f, 0x30, 0x0d, 0x82, 0x0b]+ ++ map (fromIntegral . fromEnum) "example.com"+ ++ [0xa1, 0x0c, 0x30, 0x0a, 0x87, 0x08, 10, 0, 0, 0, 255, 0, 0, 0]++-- Unknown key usage bits and a bogus bit string length are ignored.+property_key_usage_unknown_bits :: Bool+property_key_usage_unknown_bits =+ extDecode [BitString (toBitArray (B.pack [0x80, 0x40]) 6)]+ == Right (ExtKeyUsage [KeyUsage_digitalSignature])+ && extDecode [BitString (toBitArray B.empty 7)] == Right (ExtKeyUsage [])++property_malformed_extensions :: Bool+property_malformed_extensions =+ isLeft+ ( extDecode [Start Sequence, IntVal 1, End Sequence]+ :: Either String ExtExtendedKeyUsage+ )+ && isLeft+ ( extDecode [Start Sequence, End Sequence]+ :: Either String ExtCrlDistributionPoints+ )+ where+ isLeft = either (const True) (const False)++-- Unsupported GeneralName types in a SAN are skipped, but not in constraints.+property_san_skips_unknown :: Bool+property_san_skips_unknown =+ extDecode+ ( [Start Sequence]+ ++ registeredID+ ++ [Other Context 2 (B.pack [0x61])]+ ++ otherName+ ++ [Start (Container Context 4)]+ ++ toASN1 dn [End (Container Context 4)]+ ++ [End Sequence]+ )+ == Right (ExtSubjectAltName [AltNameDNS "a", AltNameDN dn])+ && isLeft+ ( extDecode+ ( [Start Sequence, Start (Container Context 0), Start Sequence]+ ++ registeredID+ ++ [End Sequence, End (Container Context 0), End Sequence]+ )+ :: Either String ExtNameConstraints+ )+ where+ dn = DistinguishedName [(getObjectID DnCommonName, asn1CharacterString UTF8 "x")]+ registeredID = [Other Context 8 (B.pack [0x2a, 0x03])]+ otherName =+ [ Start (Container Context 0)+ , OID [1, 2, 3]+ , Start (Container Context 0)+ , IntVal 1+ , End (Container Context 0)+ , End (Container Context 0)+ ]+ isLeft = either (const True) (const False)++-- A certificate whose validity cannot be decoded is rejected with 'Left'+-- rather than an exception thrown lazily from the decoder.+property_lazy_decode_error :: Bool+property_lazy_decode_error =+ case decodeSignedCertificate corrupted of+ Left e -> length e > 0+ Right _ -> False+ where+ t = timeConvert (Date 2020 January 1) :: DateTime+ dn = DistinguishedName [(getObjectID DnCommonName, asn1CharacterString UTF8 "x")]+ cert =+ Certificate+ 2+ 1+ (SignatureALG HashSHA256 PubKeyALG_RSA)+ dn+ (t, t)+ dn+ (PubKeyRSA (RSA.PublicKey 1 0x7f 3))+ (Extensions Nothing)+ encoded =+ encodeSignedObject $+ fst $+ objectToSignedExact+ (\_ -> (B.pack [1], SignatureALG HashSHA256 PubKeyALG_RSA, ()))+ cert+ -- replace the first character of the first UTCTime with a non-ASCII byte+ (before, after) = B.breakSubstring (B.pack [0x17, 0x0d]) encoded+ corrupted = before <> B.pack [0x17, 0x0d, 0xff] <> B.drop 3 after+ property_extension_id :: (Show e, Eq e, Extension e) => e -> Bool property_extension_id e = case extDecode (extEncode e) of Left err -> error err@@ -476,6 +610,20 @@ , testProperty "extended-key-usage" (property_extension_id :: ExtExtendedKeyUsage -> Bool)+ , testProperty+ "subject-alt-name"+ (property_extension_id :: ExtSubjectAltName -> Bool)+ , testProperty+ "name-constraints"+ (property_extension_id :: ExtNameConstraints -> Bool)+ , testProperty "name-constraints DER" property_name_constraints_der+ ]+ , testGroup+ "malformed"+ [ testProperty "key-usage unknown bits" property_key_usage_unknown_bits+ , testProperty "extensions" property_malformed_extensions+ , testProperty "SAN skips unknown names" property_san_skips_unknown+ , testProperty "lazy decode error" property_lazy_decode_error ] , testProperty "extensions"
crypton-x509.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: crypton-x509-version: 1.10.0+version: 1.10.1 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>