diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Data/X509/Ext.hs b/Data/X509/Ext.hs --- a/Data/X509/Ext.hs +++ b/Data/X509/Ext.hs @@ -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 = diff --git a/Data/X509/ExtensionRaw.hs b/Data/X509/ExtensionRaw.hs --- a/Data/X509/ExtensionRaw.hs +++ b/Data/X509/ExtensionRaw.hs @@ -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] diff --git a/Data/X509/Internal.hs b/Data/X509/Internal.hs --- a/Data/X509/Internal.hs +++ b/Data/X509/Internal.hs @@ -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 #-} diff --git a/Data/X509/PublicKey.hs b/Data/X509/PublicKey.hs --- a/Data/X509/PublicKey.hs +++ b/Data/X509/PublicKey.hs @@ -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" diff --git a/Data/X509/Signed.hs b/Data/X509/Signed.hs --- a/Data/X509/Signed.hs +++ b/Data/X509/Signed.hs @@ -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 diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -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" diff --git a/crypton-x509.cabal b/crypton-x509.cabal --- a/crypton-x509.cabal +++ b/crypton-x509.cabal @@ -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