Merge pull request #3620 from input-output-hk/KtorZ/CO-389/cardano-sl-x509-as-library

[CO-389] Write properties for cardano-sl-x509

Author: KtorZ

pkgs/default.nix

@@ -17900,6 +17900,7 @@ license = stdenv.lib.licenses.mit;
 , cardano-sl-util
 , cardano-sl-util-test
 , cardano-sl-wallet
+, cardano-sl-x509
 , cassava
 , cereal
 , conduit
@@ -18018,6 +18019,7 @@ cardano-sl-networking
 cardano-sl-node-ipc
 cardano-sl-util
 cardano-sl-wallet
+cardano-sl-x509
 cereal
 conduit
 connection
@@ -18248,8 +18250,8 @@ license = stdenv.lib.licenses.mit;
 , filepath
 , hourglass
 , ip
-, network-transport
 , optparse-applicative
+, QuickCheck
 , stdenv
 , text
 , universum
@@ -18282,7 +18284,6 @@ data-default-class
 filepath
 hourglass
 ip
-network-transport
 optparse-applicative
 text
 universum
@@ -18292,6 +18293,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";

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)

wallet-new/cardano-sl-wallet-new.cabal

@@ -191,6 +191,7 @@ library
                      , cardano-sl-node-ipc
                      , cardano-sl-util
                      , cardano-sl-wallet
+                     , cardano-sl-x509
                      , cereal
                      , conduit
                      , connection

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

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)

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

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:
 --     <configuration-key>:
 --       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 =