From 560df73508006f49379943849206120232e87599 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 17 Sep 2018 16:41:42 +0200 Subject: [PATCH 1/3] [CO-389] Write property for x509 cert generation This make sure that for any configuration, we actually generate valid certificates. Note that the property doesn't pass for we provide AltDNS that are IP addresses and this turns out to be invalid. The underlying v3 extensions only supports DNS names and we should make sure we properly throw when given an IP address --- x509/cardano-sl-x509.cabal | 19 +++++ x509/src/Cardano/X509/Configuration.hs | 8 +- x509/test/Main.hs | 36 ++++++++ .../Cardano/X509/Configuration/Arbitrary.hs | 84 +++++++++++++++++++ 4 files changed, 143 insertions(+), 4 deletions(-) create mode 100644 x509/test/Main.hs create mode 100644 x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs diff --git a/x509/cardano-sl-x509.cabal b/x509/cardano-sl-x509.cabal index 6aeab75f72e..e3ac6cb6a02 100644 --- a/x509/cardano-sl-x509.cabal +++ b/x509/cardano-sl-x509.cabal @@ -46,3 +46,22 @@ library exposed-modules: Data.X509.Extra Cardano.X509.Configuration + +test-suite cardano-sl-x509-test + default-language: Haskell2010 + default-extensions: DeriveGeneric + NoImplicitPrelude + OverloadedStrings + TupleSections + TypeApplications + type: exitcode-stdio-1.0 + + hs-source-dirs: test + main-is: Main.hs + other-modules: Test.Cardano.X509.Configuration.Arbitrary + + build-depends: base + , QuickCheck + , cardano-sl-x509 + , universum + diff --git a/x509/src/Cardano/X509/Configuration.hs b/x509/src/Cardano/X509/Configuration.hs index eb36445b422..3cbb3d06cf1 100644 --- a/x509/src/Cardano/X509/Configuration.hs +++ b/x509/src/Cardano/X509/Configuration.hs @@ -76,7 +76,7 @@ data TLSConfiguration = TLSConfiguration { tlsCa :: CertConfiguration , tlsServer :: ServerConfiguration , tlsClients :: [CertConfiguration] - } deriving (Generic) + } deriving (Generic, Show, Eq) instance FromJSON TLSConfiguration where parseJSON = Aeson.genericParseJSON (aesonDropPrefix "tls") @@ -86,14 +86,14 @@ data DirConfiguration = DirConfiguration { outDirServer :: FilePath , outDirClients :: FilePath , outDirCA :: Maybe FilePath - } + } deriving (Generic, Show, Eq) -- | Foreign Certificate Configuration data CertConfiguration = CertConfiguration { certOrganization :: String , certCommonName :: String , certExpiryDays :: Int - } deriving (Generic) + } deriving (Generic, Show, Eq) instance FromJSON CertConfiguration where parseJSON = Aeson.genericParseJSON (aesonDropPrefix "cert") @@ -102,7 +102,7 @@ instance FromJSON CertConfiguration where data ServerConfiguration = ServerConfiguration { serverConfiguration :: CertConfiguration , serverAltNames :: NonEmpty String - } + } deriving (Generic, Show, Eq) -- NOTE We keep the declaration structure 'flat' such that servers config -- are simply client config with an extra field 'altDNS' diff --git a/x509/test/Main.hs b/x509/test/Main.hs new file mode 100644 index 00000000000..87a8e7e1488 --- /dev/null +++ b/x509/test/Main.hs @@ -0,0 +1,36 @@ +module Main where + +import Universum + +import qualified Data.List.NonEmpty as NonEmpty +import Test.QuickCheck (Property, conjoin, ioProperty, quickCheck, + withMaxSuccess, (===)) + +import Cardano.X509.Configuration (CertDescription (..), + DirConfiguration (..), ServerConfiguration (..), + TLSConfiguration (..), fromConfiguration, genCertificate) +import Data.X509.Extra (genRSA256KeyPair, validateSHA256) +import Test.Cardano.X509.Configuration.Arbitrary () + + +main :: IO () +main = quickCheck $ + propGenCertificateValid + + +propGenCertificateValid :: (TLSConfiguration, DirConfiguration) -> Property +propGenCertificateValid (tlsConf, dirConf) = ioProperty $ do + (caDesc, certDescs) <- + fromConfiguration tlsConf dirConf genRSA256KeyPair <$> genRSA256KeyPair + + (_, caCert) <- genCertificate caDesc + + let serverId = (NonEmpty.head $ serverAltNames $ tlsServer tlsConf, "") + + fmap conjoin $ forM certDescs $ \desc -> do + (_, cert) <- genCertificate desc + + errors <- + validateSHA256 caCert (certChecks desc) serverId cert + + return (errors === []) diff --git a/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs b/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs new file mode 100644 index 00000000000..7560a198855 --- /dev/null +++ b/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs @@ -0,0 +1,84 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Cardano.X509.Configuration.Arbitrary () where + +import Universum + +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Test.QuickCheck (Arbitrary (..), Gen, elements, listOf, + listOf1, oneof, scale, suchThat) +import Test.QuickCheck.Modifiers (Positive (..)) + +import Cardano.X509.Configuration (CertConfiguration (..), + DirConfiguration (..), ServerConfiguration (..), + TLSConfiguration (..)) + + +instance Arbitrary TLSConfiguration where + arbitrary = TLSConfiguration + <$> arbitrary + <*> arbitrary + <*> scale (`mod` 5) (listOf arbitrary) + + shrink (TLSConfiguration ca server clients) = + TLSConfiguration ca server <$> shrink clients + + +instance Arbitrary CertConfiguration where + arbitrary = CertConfiguration + <$> elements ["IOHK", "Emurgo", "Cardano Foundation"] + <*> elements ["Daedalus Wallet", "Icarus Wallet", "Prometheus", "Root CA"] + <*> arbitraryPositive + + shrink (CertConfiguration org name days) = + CertConfiguration org name . getPositive <$> shrink (Positive days) + + +instance Arbitrary ServerConfiguration where + arbitrary = ServerConfiguration + <$> arbitrary + <*> fmap getAltNames arbitrary + + shrink (ServerConfiguration cert altNames) = + mkServerConfiguration <$> shrink (cert, AltNames altNames) + + +instance Arbitrary DirConfiguration where + arbitrary = DirConfiguration + <$> arbitraryBasicString + <*> arbitraryBasicString + <*> oneof [pure Nothing, Just <$> arbitraryBasicString] + + shrink _ = [] + + +instance Arbitrary AltNames where + arbitrary = + fmap mkAltNames $ listOf1 $ elements + ["127.0.0.1", "localhost", "::1", "localhost.localdomain"] + + shrink (AltNames xs) = + case xs of + (_ :| []) -> [] + (x :| rest) -> + mkAltNames <$> filter (not . null) (shrink (x:rest)) + + +newtype AltNames = AltNames { getAltNames :: NonEmpty String } + +mkAltNames :: [String] -> AltNames +mkAltNames = + AltNames . NonEmpty.fromList . List.nub + +mkServerConfiguration :: (CertConfiguration, AltNames) -> ServerConfiguration +mkServerConfiguration = + uncurry ServerConfiguration . second getAltNames + +arbitraryPositive :: Gen Int +arbitraryPositive = fmap getPositive arbitrary + +arbitraryBasicString :: Gen String +arbitraryBasicString = + listOf (suchThat arbitrary Char.isLetter) From 88dc6130952f56edfb96a6469e30505e68fc26fc Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 17 Sep 2018 17:57:01 +0200 Subject: [PATCH 2/3] [CO-389] Fix x509 generation: throw when provided invalid config e.g. - given a non-positive expiry days - given an unknown ServiceID --- tools/src/gencerts/Main.hs | 4 +- wallet-new/cardano-sl-wallet-new.cabal | 1 + wallet-new/src/Cardano/Wallet/Client/Http.hs | 4 + x509/README.md | 14 +- x509/cardano-sl-x509.cabal | 3 +- x509/src/Cardano/X509/Configuration.hs | 96 ++++++------ x509/src/Data/X509/Extra.hs | 110 ++++++++++++- x509/test/Main.hs | 147 ++++++++++++++++-- .../Cardano/X509/Configuration/Arbitrary.hs | 87 ++++++++++- 9 files changed, 383 insertions(+), 83 deletions(-) diff --git a/tools/src/gencerts/Main.hs b/tools/src/gencerts/Main.hs index bbd962569a7..165358c8507 100644 --- a/tools/src/gencerts/Main.hs +++ b/tools/src/gencerts/Main.hs @@ -16,7 +16,7 @@ import Cardano.X509.Configuration (CertDescription (..), ServerConfiguration (..), TLSConfiguration (..), decodeConfigFile, fromConfiguration, genCertificate) import Data.X509.Extra (failIfReasons, genRSA256KeyPair, - validateSHA256, writeCertificate, writeCredentials) + validateCertificate, writeCertificate, writeCredentials) data Command = Command @@ -79,7 +79,7 @@ main = do forM_ descs $ \desc -> do (key, cert) <- genCertificate desc - failIfReasons =<< validateSHA256 + failIfReasons =<< validateCertificate caCert (certChecks desc) (serverHost, serverPort) diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index c46badef2cc..5e22e3dabf8 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -192,6 +192,7 @@ library , cardano-sl-node-ipc , cardano-sl-util , cardano-sl-wallet + , cardano-sl-x509 , cereal , conduit , connection diff --git a/wallet-new/src/Cardano/Wallet/Client/Http.hs b/wallet-new/src/Cardano/Wallet/Client/Http.hs index 3516b60717a..de20689078e 100644 --- a/wallet-new/src/Cardano/Wallet/Client/Http.hs +++ b/wallet-new/src/Cardano/Wallet/Client/Http.hs @@ -8,6 +8,7 @@ module Cardano.Wallet.Client.Http , module Servant.Client -- * Helper to load X509 certificates and private key , credentialLoadX509 + , readSignedObject , newManager , Manager ) where @@ -20,6 +21,8 @@ import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) import Data.X509 (CertificateChain, SignedCertificate) import Data.X509.CertificateStore (makeCertificateStore) +import Data.X509.Extra (validateDefaultWithIP) +import Data.X509.File (readSignedObject) import Network.Connection (TLSSettings (..)) import Network.HTTP.Client (Manager, ManagerSettings, defaultManagerSettings, newManager) @@ -73,6 +76,7 @@ mkHttpsManagerSettings serverId caChain credentials = } clientHooks = def { onCertificateRequest = const . return . Just $ credentials + , onServerCertificate = validateDefaultWithIP } clientSupported = def { supportedCiphers = ciphersuite_default diff --git a/x509/README.md b/x509/README.md index f678f8c441c..985d04f648b 100644 --- a/x509/README.md +++ b/x509/README.md @@ -14,12 +14,14 @@ import Data.X509.Extra (genRSA256KeyPair) main :: IO () main = do + confFile <- + decodeConfigFile "dev" "lib/configuration.yaml" + + let dirConf = + DirConfiguration "server" "client" Nothing + (caDesc, certDescs) <- - fromConfiguration - <$> decodeConfigFile "dev" "lib/configuration.yaml" - <*> pure (DirConfiguration "server" "client" Nothing) - <*> pure genRSA256KeyPair - <*> genRSA256KeyPair + fromConfiguration confFile dirConf genRSA256KeyPair <$> genRSA256KeyPair (caKey, caCert) <- genCertificate caDesc @@ -34,7 +36,7 @@ main = do where findCert :: String - -> [CertDescription IO PublicKey PrivateKey String] + -> [CertDescription IO PublicKey PrivateKey String] -> CertDescription IO PublicKey PrivateKey String findCert outDir = head . find ((== outDir) . certOutDir) diff --git a/x509/cardano-sl-x509.cabal b/x509/cardano-sl-x509.cabal index e3ac6cb6a02..71477627bf7 100644 --- a/x509/cardano-sl-x509.cabal +++ b/x509/cardano-sl-x509.cabal @@ -34,7 +34,6 @@ library , filepath , hourglass , ip - , network-transport , optparse-applicative , text , universum @@ -54,6 +53,7 @@ test-suite cardano-sl-x509-test OverloadedStrings TupleSections TypeApplications + type: exitcode-stdio-1.0 hs-source-dirs: test @@ -64,4 +64,3 @@ test-suite cardano-sl-x509-test , QuickCheck , cardano-sl-x509 , universum - diff --git a/x509/src/Cardano/X509/Configuration.hs b/x509/src/Cardano/X509/Configuration.hs index 3cbb3d06cf1..fad85881c2f 100644 --- a/x509/src/Cardano/X509/Configuration.hs +++ b/x509/src/Cardano/X509/Configuration.hs @@ -17,10 +17,12 @@ module Cardano.X509.Configuration -- * Description of Certificates , CertDescription(..) - , fromConfiguration -- * Effectful Functions , ConfigurationKey(..) + , ErrInvalidTLSConfiguration + , ErrInvalidExpiryDays + , fromConfiguration , decodeConfigFile , genCertificate ) where @@ -36,34 +38,27 @@ import Data.Hourglass (Minutes (..), Period (..), dateAddPeriod, import Data.List (stripPrefix) import Data.Semigroup ((<>)) import Data.String (fromString) -import Data.X509 (AltName (..), DistinguishedName (..), - DnElement (..), ExtAuthorityKeyId (..), - ExtBasicConstraints (..), ExtExtendedKeyUsage (..), - ExtKeyUsage (..), ExtKeyUsageFlag (..), - ExtKeyUsagePurpose (..), ExtSubjectAltName (..), - ExtSubjectKeyId (..), ExtensionRaw, Extensions (..), - PubKey (..), SignedCertificate, extensionEncode, hashDN) +import Data.X509 (DistinguishedName (..), DnElement (..), + ExtAuthorityKeyId (..), ExtBasicConstraints (..), + ExtExtendedKeyUsage (..), ExtKeyUsage (..), + ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..), + ExtSubjectAltName (..), ExtSubjectKeyId (..), + ExtensionRaw, Extensions (..), PubKey (..), + SignedCertificate, extensionEncode, hashDN) import Data.X509.Validation (ValidationChecks (..), defaultChecks) import Data.Yaml (decodeFileEither, parseMonad, withObject) import GHC.Generics (Generic) -import Net.IP (IP, case_, decode) -import Net.IPv4 (IPv4 (..)) -import Net.IPv6 (IPv6 (..)) -import Network.Transport.Internal (encodeWord32) import System.IO (FilePath) import Time.System (dateCurrent) import Time.Types (DateTime (..)) -import Data.X509.Extra (signAlgRSA256, signCertificate) +import Data.X509.Extra (parseSAN, signAlgRSA256, signCertificate) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import qualified Data.ByteString.Builder as BS -import qualified Data.ByteString.Lazy as LBS import qualified Data.Char as Char import qualified Data.HashMap.Lazy as HM import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Text as T import qualified Data.X509 as X509 @@ -137,12 +132,37 @@ data CertDescription m pub priv outdir = CertDescription } +-- +-- Effectful Functions +-- + + +-- | Type-alias for signature readability +newtype ConfigurationKey = ConfigurationKey + { getConfigurationKey :: String + } deriving (Eq, Show) + + +newtype ErrInvalidExpiryDays + = ErrInvalidExpiryDays String + deriving (Show) + +instance Exception ErrInvalidExpiryDays + + +newtype ErrInvalidTLSConfiguration + = ErrInvalidTLSConfiguration String + deriving (Show) + +instance Exception ErrInvalidTLSConfiguration + + -- | Describe a list of certificates to generate & sign from a foreign config -- -- Description can then be used with @genCertificate@ to obtain corresponding -- certificate fromConfiguration - :: Applicative m + :: (Applicative m) => TLSConfiguration -- ^ Foreign TLS configuration / setup -> DirConfiguration -- ^ Output directories configuration -> m (pub, priv) -- ^ Key pair generator @@ -201,15 +221,6 @@ fromConfiguration tlsConf dirConf genKeys (caPub, caPriv) = (caConfig, svConfig : clConfigs) --- --- Effectful Functions --- - --- | Type-alias for signature readability -newtype ConfigurationKey = ConfigurationKey - { getConfigurationKey :: String - } deriving (Eq, Show) - -- | Decode a configuration file (.yaml). The expected file structure is: -- : -- tls: @@ -220,17 +231,18 @@ newtype ConfigurationKey = ConfigurationKey -- where the 'configuration-key' represents the target environment (dev, test, -- bench, etc.). decodeConfigFile - :: (MonadIO m, MonadFail m) + :: (MonadIO m, MonadThrow m) => ConfigurationKey -- ^ Target configuration Key -> FilePath -- ^ Target configuration file -> m TLSConfiguration decodeConfigFile (ConfigurationKey cKey) filepath = decodeFileMonad filepath >>= parseMonad parser where - errMsg key = "Invalid TLS Configuration: property '"<> key <> "' " <> - "not found in configuration file." + errMsg key = "property '"<> key <> "' " <> "not found in configuration file." - decodeFileMonad = (liftIO . decodeFileEither) >=> either (fail . show) return + decodeFileMonad = (liftIO . decodeFileEither) >=> either + (throwM . ErrInvalidTLSConfiguration . show) + return parser = withObject "TLS Configuration" (parseK cKey >=> parseK "tls") @@ -246,6 +258,10 @@ genCertificate desc = do ((pub, priv), now) <- (,) <$> (certGenKeys desc) <*> dateCurrent let conf = certConfiguration desc + + when (certExpiryDays conf <= 0) $ + throwM $ ErrInvalidExpiryDays "expiry days should be a positive integer" + let cert = X509.Certificate { X509.certVersion = 2 , X509.certSerial = fromIntegral (certSerial desc) @@ -307,24 +323,12 @@ usExtensionsV3 purpose subDN issDN = svExtensionsV3 :: DistinguishedName -> DistinguishedName -> NonEmpty String -> [ExtensionRaw] svExtensionsV3 subDN issDN altNames = let - subjectAltName = ExtSubjectAltName ( parseAltName <$> NonEmpty.toList altNames) + subjectAltName = + ExtSubjectAltName $ map parseSAN (NonEmpty.toList altNames) in - extensionEncode False subjectAltName : usExtensionsV3 KeyUsagePurpose_ServerAuth subDN issDN + extensionEncode False subjectAltName : + usExtensionsV3 KeyUsagePurpose_ServerAuth subDN issDN -parseAltName :: String -> AltName -parseAltName name = do - let - ipv4ToByteString :: IPv4 -> ByteString - ipv4ToByteString (IPv4 bytes) = encodeWord32 bytes - ipv6ToByteString :: IPv6 -> ByteString - ipv6ToByteString ipv6 = LBS.toStrict (BS.toLazyByteString $ ipv6ByteStringBuilder ipv6) - ipv6ByteStringBuilder :: IPv6 -> BS.Builder - ipv6ByteStringBuilder (IPv6 parta partb) = BS.word64BE parta <> BS.word64BE partb - - go :: Maybe IP -> AltName - go (Just address) = AltNameIP $ case_ ipv4ToByteString ipv6ToByteString address - go Nothing = AltNameDNS name - go $ decode $ T.pack name clExtensionsV3 :: DistinguishedName -> DistinguishedName -> [ExtensionRaw] clExtensionsV3 = diff --git a/x509/src/Data/X509/Extra.hs b/x509/src/Data/X509/Extra.hs index 4401409526a..a1171985806 100644 --- a/x509/src/Data/X509/Extra.hs +++ b/x509/src/Data/X509/Extra.hs @@ -9,11 +9,13 @@ module Data.X509.Extra -- * RSA/SHA-256 Applied Constructors signAlgRSA256 , signCertificate - , validateSHA256 , genRSA256KeyPair + , validateDefaultWithIP + , validateCertificate -- * Utils , failIfReasons + , parseSAN -- * RSA Encode PEM , EncodePEM (..) @@ -21,6 +23,10 @@ module Data.X509.Extra -- * Effectful IO Functions , writeCredentials , writeCertificate + + -- * Re-Export + , module Data.X509 + , module Data.X509.Validation ) where import Universum @@ -31,19 +37,27 @@ import Crypto.PubKey.RSA.PKCS15 (signSafer) import Crypto.Random.Types (MonadRandom) import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (encodeASN1) -import Data.ASN1.Types (ASN1 (..), ASN1ConstructionType (..)) +import Data.ASN1.Types (ASN1 (..), ASN1ConstructionType (..), + asn1CharacterToString) import Data.ByteString (ByteString) import Data.Default.Class import Data.List (intercalate) import Data.X509 -import Data.X509.CertificateStore (makeCertificateStore) -import Data.X509.Validation (FailedReason, ServiceID, - ValidationChecks (..), defaultHooks, validate) +import Data.X509.CertificateStore (CertificateStore, + makeCertificateStore) +import Data.X509.Validation +import Net.IP (IP) import qualified Crypto.PubKey.RSA.Types as RSA import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Net.IP as IP +import qualified Net.IPv4 as IPv4 +import qualified Net.IPv6 as IPv6 -- @@ -70,17 +84,32 @@ signCertificate key = either (fail . show) (return . (,signAlgRSA256)) +-- | Drop-in replacement for 'validateDefault' but with support for IP SAN +validateDefaultWithIP + :: CertificateStore + -> ValidationCache + -> ServiceID + -> CertificateChain + -> IO [FailedReason] +validateDefaultWithIP = + validate HashSHA256 hooks checks + where + hooks = defaultHooks { hookValidateName = validateCertificateName } + checks = defaultChecks + + -- | Validate a X.509 certificate using SHA256 hash and a given CA. This is -- merely to verify that we aren't generating invalid certificates. -validateSHA256 +validateCertificate :: SignedCertificate -> ValidationChecks -> ServiceID -> SignedCertificate -> IO [FailedReason] -validateSHA256 caCert checks sid cert = - validate HashSHA256 defaultHooks checks store def sid chain +validateCertificate caCert checks sid cert = + validate HashSHA256 hooks checks store def sid chain where + hooks = defaultHooks { hookValidateName = validateCertificateName } store = makeCertificateStore [caCert] chain = CertificateChain [cert] @@ -141,6 +170,17 @@ failIfReasons = \case xs -> fail $ "Generated invalid certificate: " ++ intercalate ", " (map show xs) +-- | Parse a Subject Alternative Name (SAN) from a raw string +parseSAN :: String -> AltName +parseSAN name = + case IP.decode (toText name) of + Just ip -> + AltNameIP . T.encodeUtf8 $ IP.case_ IPv4.encode IPv6.encode ip + + Nothing -> + AltNameDNS name + + -- -- Effectful IO Functions -- @@ -192,3 +232,57 @@ encodeDERRSAPrivateKey = , IntVal qInv , End Sequence ] + + +-- | Helper to decode an IP address from raw bytes +ipFromBytes :: ByteString -> Maybe IP +ipFromBytes = + IP.decode . T.decodeUtf8 + + +-- | Hook to validate a certificate name. It only validates DNS and IPs names +-- against the provided hostname. It fails otherwise. +validateCertificateName :: HostName -> Certificate -> [FailedReason] +validateCertificateName fqhn = + case parseSAN fqhn of + AltNameIP bytes -> + case ipFromBytes bytes of + Nothing -> const [InvalidName fqhn] + Just ip -> validateCertificateIP ip + _ -> + validateCertificateDNS fqhn + + +-- | Hook to validate certificate DNS, using the default hook from +-- x509-validation which does exactly that. +validateCertificateDNS :: HostName -> Certificate -> [FailedReason] +validateCertificateDNS = + hookValidateName defaultHooks + + +-- | Basic validation against the host if it turns out to be an IP address +validateCertificateIP :: IP -> Certificate -> [FailedReason] +validateCertificateIP ip cert = + let + commonName :: Maybe IP + commonName = + toCommonName =<< getDnElement DnCommonName (certSubjectDN cert) + + altNames :: [IP] + altNames = + maybe [] toAltName $ extensionGet $ certExtensions cert + + toAltName :: ExtSubjectAltName -> [IP] + toAltName (ExtSubjectAltName sans) = + catMaybes $ flip map sans $ \case + AltNameIP bytes -> ipFromBytes bytes + _ -> Nothing + + toCommonName :: ASN1CharacterString -> Maybe IP + toCommonName = + asn1CharacterToString >=> (ipFromBytes . B8.pack) + in + if any (== ip) (maybeToList commonName ++ altNames) then + [] + else + [NameMismatch $ T.unpack $ IP.encode ip] diff --git a/x509/test/Main.hs b/x509/test/Main.hs index 87a8e7e1488..9cf5873bfcb 100644 --- a/x509/test/Main.hs +++ b/x509/test/Main.hs @@ -1,36 +1,153 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Main where import Universum import qualified Data.List.NonEmpty as NonEmpty -import Test.QuickCheck (Property, conjoin, ioProperty, quickCheck, - withMaxSuccess, (===)) +import Data.Maybe (fromJust) +import Test.QuickCheck (Property, Result (..), conjoin, + counterexample, ioProperty, label, property, + quickCheckResult, withMaxSuccess, (===)) import Cardano.X509.Configuration (CertDescription (..), - DirConfiguration (..), ServerConfiguration (..), - TLSConfiguration (..), fromConfiguration, genCertificate) -import Data.X509.Extra (genRSA256KeyPair, validateSHA256) -import Test.Cardano.X509.Configuration.Arbitrary () + DirConfiguration (..), ErrInvalidExpiryDays, + ServerConfiguration (..), TLSConfiguration (..), + fromConfiguration, genCertificate) +import Data.X509.Extra (ExtExtendedKeyUsage (..), + ExtKeyUsagePurpose (..), FailedReason, ServiceID, + extensionGet, genRSA256KeyPair, getCertificate, + validateCertificate) +import qualified Data.X509.Extra as X509 +import Test.Cardano.X509.Configuration.Arbitrary (AltNames (..), + Invalid (..), Unknown (..)) + +-- +-- Main +-- main :: IO () -main = quickCheck $ - propGenCertificateValid +main = runQuickCheck + [ quickCheckResult $ label "GenCertificate is Valid" propGenCertificateValid + , quickCheckResult $ label "validateCertificate fails for unknown ServiceID" propUnknownService + , quickCheckResult $ label "Invalid Expiry Days throws" propInvalidExpiryDays + ] + where + -- NOTE running 'quickCheck prop' doesn't make 'cabal test' fails + -- even if the property fails. So this little one cope with this + -- by running all specs and failing if one of them returned a failure. + runQuickCheck :: [IO Result] -> IO () + runQuickCheck = + sequence >=> (mapM_ $ \case + Success {} -> return () + _ -> exitFailure) + + +-- +-- Properties +-- + +-- | Verify that each certificate generated is valid. Is uses the default +-- validation check of 'Data.X509.Validation' +propGenCertificateValid + :: (TLSConfiguration, DirConfiguration) + -> Property +propGenCertificateValid = + ioProperty . generateAndValidate getValidServiceID propAllCertsValid + + +-- | Verify that each server certificate generated is invalid when provided an +-- unknown ServiceID. +propUnknownService + :: Unknown AltNames + -> (TLSConfiguration, DirConfiguration) + -> Property +propUnknownService altNames = + ioProperty . generateAndValidate (getUnknownServiceID altNames) propServerCertsInvalid + + +-- | Verify that we can't generate certificates when provided invalid +-- expiry days. +propInvalidExpiryDays + :: (Invalid TLSConfiguration, DirConfiguration) + -> Property +propInvalidExpiryDays (Invalid tlsConf, dirConf) = + withMaxSuccess 10 $ ioProperty $ generateAndValidate getValidServiceID propAllCertsValid (tlsConf, dirConf) + `catch` (\(_ :: ErrInvalidExpiryDays) -> return $ property True) + `catch` (\(e :: SomeException) -> throwM e) + +-- | Check that there's no validation FailedReason +propAllCertsValid + :: ExtExtendedKeyUsage + -> [FailedReason] + -> Property +propAllCertsValid _ = + (=== []) -propGenCertificateValid :: (TLSConfiguration, DirConfiguration) -> Property -propGenCertificateValid (tlsConf, dirConf) = ioProperty $ do + +-- | Check that there are actually some validation FailedReason for non-client +-- certificate +propServerCertsInvalid + :: ExtExtendedKeyUsage + -> [FailedReason] + -> Property +propServerCertsInvalid (ExtExtendedKeyUsage purposes) = + if KeyUsagePurpose_ClientAuth `elem` purposes then + const (property True) + else + (=/= []) + + +-- | Actually generate certificates and validate them with the given property +-- Throws on error. +generateAndValidate + :: (TLSConfiguration -> ServiceID) + -> (ExtExtendedKeyUsage -> [FailedReason] -> Property) + -> (TLSConfiguration, DirConfiguration) + -> IO (Property) +generateAndValidate getServiceID predicate (tlsConf, dirConf) = do (caDesc, certDescs) <- fromConfiguration tlsConf dirConf genRSA256KeyPair <$> genRSA256KeyPair (_, caCert) <- genCertificate caDesc - let serverId = (NonEmpty.head $ serverAltNames $ tlsServer tlsConf, "") - fmap conjoin $ forM certDescs $ \desc -> do (_, cert) <- genCertificate desc - errors <- - validateSHA256 caCert (certChecks desc) serverId cert + let extendedKeyUsage = + fromJust $ extensionGet $ X509.certExtensions $ getCertificate cert + + predicate extendedKeyUsage <$> + validateCertificate caCert (certChecks desc) (getServiceID tlsConf) cert + + +-- | Get a valid serviceID from the configuration +getValidServiceID + :: TLSConfiguration + -> ServiceID +getValidServiceID tlsConf = + (NonEmpty.head $ serverAltNames $ tlsServer tlsConf, "") + + +-- | Get an invalid serviceID from the configuration +getUnknownServiceID + :: Unknown AltNames + -> TLSConfiguration + -> ServiceID +getUnknownServiceID (Unknown (AltNames (name :| _))) _ = + (name, "") + - return (errors === []) +-- | Like '/=', but prints a counterexample when it fails. +-- Source: QuickCheck@2.12 Test.QuickCheck.Property#(=/=) +infix 4 =/= +(=/=) :: (Eq a, Show a) => a -> a -> Property +x =/= y = + counterexample (show x ++ interpret res ++ show y) res + where + res = x /= y + interpret True = " /= " + interpret False = " == " diff --git a/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs b/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs index 7560a198855..7a2643f20a3 100644 --- a/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs +++ b/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs @@ -1,13 +1,19 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} -module Test.Cardano.X509.Configuration.Arbitrary () where +module Test.Cardano.X509.Configuration.Arbitrary + ( Invalid(..) + , Unknown(..) + , AltNames(..) + ) where import Universum import qualified Data.Char as Char import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty -import Test.QuickCheck (Arbitrary (..), Gen, elements, listOf, +import Test.QuickCheck (Arbitrary (..), Gen, choose, elements, listOf, listOf1, oneof, scale, suchThat) import Test.QuickCheck.Modifiers (Positive (..)) @@ -16,6 +22,28 @@ import Cardano.X509.Configuration (CertConfiguration (..), TLSConfiguration (..)) +-- +-- Types +-- + +-- | Helper to declare Arbitrary instances with generators that +-- generate invalid values +newtype (Show a) => Invalid a = Invalid { getInvalid :: a } deriving (Show) + + +-- | Helper to declare Arbitrary instances with generators that +-- generate unkown valus +newtype (Show a) => Unknown a = Unknown { getUnknown :: a } deriving (Show) + + +-- | Easily generate alternative names +newtype AltNames = AltNames { getAltNames :: NonEmpty String } deriving (Show) + + +-- +-- Instances +-- + instance Arbitrary TLSConfiguration where arbitrary = TLSConfiguration <$> arbitrary @@ -26,6 +54,16 @@ instance Arbitrary TLSConfiguration where TLSConfiguration ca server <$> shrink clients +instance Arbitrary (Invalid TLSConfiguration) where + arbitrary = fmap Invalid $ TLSConfiguration + <$> arbitraryInvalid + <*> arbitraryInvalid + <*> scale (`mod` 5) (listOf arbitraryInvalid) + + shrink (Invalid tlsConf) = + Invalid <$> shrink tlsConf + + instance Arbitrary CertConfiguration where arbitrary = CertConfiguration <$> elements ["IOHK", "Emurgo", "Cardano Foundation"] @@ -36,6 +74,16 @@ instance Arbitrary CertConfiguration where CertConfiguration org name . getPositive <$> shrink (Positive days) +instance Arbitrary (Invalid CertConfiguration) where + arbitrary = fmap Invalid $ CertConfiguration + <$> elements ["IOHK", "Emurgo", "Cardano Foundation"] + <*> elements ["Daedalus Wallet", "Icarus Wallet", "Prometheus", "Root CA"] + <*> choose (-10, 10) + + shrink (Invalid (CertConfiguration org name days)) = + (Invalid . CertConfiguration org name) <$> shrink days + + instance Arbitrary ServerConfiguration where arbitrary = ServerConfiguration <$> arbitrary @@ -45,6 +93,15 @@ instance Arbitrary ServerConfiguration where mkServerConfiguration <$> shrink (cert, AltNames altNames) +instance Arbitrary (Invalid ServerConfiguration) where + arbitrary = fmap Invalid $ ServerConfiguration + <$> arbitraryInvalid + <*> fmap getAltNames arbitrary + + shrink (Invalid serverConf) = + Invalid <$> shrink serverConf + + instance Arbitrary DirConfiguration where arbitrary = DirConfiguration <$> arbitraryBasicString @@ -57,7 +114,11 @@ instance Arbitrary DirConfiguration where instance Arbitrary AltNames where arbitrary = fmap mkAltNames $ listOf1 $ elements - ["127.0.0.1", "localhost", "::1", "localhost.localdomain"] + [ "localhost" + , "localhost.localdomain" + , "127.0.0.1" + , "::1" + ] shrink (AltNames xs) = case xs of @@ -66,7 +127,21 @@ instance Arbitrary AltNames where mkAltNames <$> filter (not . null) (shrink (x:rest)) -newtype AltNames = AltNames { getAltNames :: NonEmpty String } +instance Arbitrary (Unknown AltNames) where + arbitrary = + fmap (Unknown . mkAltNames) $ listOf1 $ elements + [ "www.iohk.io" + , "14.14.14.14" + , "2607:f0d0:1002:0051:0000:0000:0000:0004" + ] + + shrink (Unknown altNames) = + Unknown <$> shrink altNames + + +-- +-- Internals +-- mkAltNames :: [String] -> AltNames mkAltNames = @@ -82,3 +157,7 @@ arbitraryPositive = fmap getPositive arbitrary arbitraryBasicString :: Gen String arbitraryBasicString = listOf (suchThat arbitrary Char.isLetter) + +arbitraryInvalid :: (Show a, Arbitrary (Invalid a)) => Gen a +arbitraryInvalid = + fmap getInvalid arbitrary From cac524c1e52560ed4f74789b33b3f60da2f086c1 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 18 Sep 2018 08:19:02 +0200 Subject: [PATCH 3/3] [CO-389] Update pkgs/default.nix --- pkgs/default.nix | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/pkgs/default.nix b/pkgs/default.nix index f2dc12f6edd..82acaaae19e 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -17853,6 +17853,7 @@ license = stdenv.lib.licenses.mit; , cardano-sl-util , cardano-sl-util-test , cardano-sl-wallet +, cardano-sl-x509 , cassava , cereal , conduit @@ -17970,6 +17971,7 @@ cardano-sl-networking cardano-sl-node-ipc cardano-sl-util cardano-sl-wallet +cardano-sl-x509 cereal conduit connection @@ -18198,8 +18200,8 @@ license = stdenv.lib.licenses.mit; , filepath , hourglass , ip -, network-transport , optparse-applicative +, QuickCheck , stdenv , text , universum @@ -18232,7 +18234,6 @@ data-default-class filepath hourglass ip -network-transport optparse-applicative text universum @@ -18242,6 +18243,11 @@ x509-store x509-validation yaml ]; +testHaskellDepends = [ +base +QuickCheck +universum +]; doHaddock = false; homepage = "https://github.com/input-output-hk/cardano-sl/x509/README.md"; description = "Tool-suite for generating x509 certificates specialized for RSA with SHA-256";