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"; 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 6aeab75f72e..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 @@ -46,3 +45,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..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 @@ -76,7 +71,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 +81,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 +97,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' @@ -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 new file mode 100644 index 00000000000..9cf5873bfcb --- /dev/null +++ b/x509/test/Main.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Universum + +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromJust) +import Test.QuickCheck (Property, Result (..), conjoin, + counterexample, ioProperty, label, property, + quickCheckResult, withMaxSuccess, (===)) + +import Cardano.X509.Configuration (CertDescription (..), + 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 = 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 _ = + (=== []) + + +-- | 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 + + fmap conjoin $ forM certDescs $ \desc -> do + (_, cert) <- genCertificate desc + + 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, "") + + +-- | 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 new file mode 100644 index 00000000000..7a2643f20a3 --- /dev/null +++ b/x509/test/Test/Cardano/X509/Configuration/Arbitrary.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +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, choose, elements, listOf, + listOf1, oneof, scale, suchThat) +import Test.QuickCheck.Modifiers (Positive (..)) + +import Cardano.X509.Configuration (CertConfiguration (..), + DirConfiguration (..), ServerConfiguration (..), + 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 + <*> arbitrary + <*> scale (`mod` 5) (listOf arbitrary) + + shrink (TLSConfiguration ca server clients) = + 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"] + <*> elements ["Daedalus Wallet", "Icarus Wallet", "Prometheus", "Root CA"] + <*> arbitraryPositive + + shrink (CertConfiguration org name days) = + 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 + <*> fmap getAltNames arbitrary + + shrink (ServerConfiguration cert altNames) = + 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 + <*> arbitraryBasicString + <*> oneof [pure Nothing, Just <$> arbitraryBasicString] + + shrink _ = [] + + +instance Arbitrary AltNames where + arbitrary = + fmap mkAltNames $ listOf1 $ elements + [ "localhost" + , "localhost.localdomain" + , "127.0.0.1" + , "::1" + ] + + shrink (AltNames xs) = + case xs of + (_ :| []) -> [] + (x :| rest) -> + mkAltNames <$> filter (not . null) (shrink (x:rest)) + + +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 = + 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) + +arbitraryInvalid :: (Show a, Arbitrary (Invalid a)) => Gen a +arbitraryInvalid = + fmap getInvalid arbitrary