Store intermediate certificate chain with certificates

scripts/test-bootstrap-node.config

@@ -54,7 +54,7 @@ chainweb:
             QM/ThFn9xv3RUppF4aGrnfCsldXfrxmwgLvOw3qxLOCk6mHOcInRjw4Qdpk=
             -----END PRIVATE KEY-----
         interface: 127.0.0.1
-        certificate: |
+        certificateChain: |
             -----BEGIN CERTIFICATE-----
             MIIFBDCCAuygAwIBAgIBATANBgkqhkiG9w0BAQ0FADAUMRIwEAYDVQQDDAlsb2Nh
             bGhvc3QwHhcNMTgxMjIyMDM1NzM2WhcNMzAwMzEwMDM1NzM2WjAUMRIwEAYDVQQD
@@ -86,4 +86,4 @@ chainweb:
             -----END CERTIFICATE-----
         hostaddress:
             hostname: localhost
-            port: 1789
+            port: 1789

src/Chainweb/Chainweb.hs

@@ -326,7 +326,7 @@ runChainweb cw = do
         serverSettings = peerServerSettings (_peerResPeer $ _chainwebPeer cw)
         serve = serveChainwebSocketTls
             serverSettings
-            (_peerCertificate $ _peerResPeer $ _chainwebPeer cw)
+            (_peerCertificateChain $ _peerResPeer $ _chainwebPeer cw)
             (_peerKey $ _peerResPeer $ _chainwebPeer cw)
             (_peerResSocket $ _chainwebPeer cw)
             (_chainwebVersion cw)

src/Chainweb/Chainweb/PeerResources.hs

@@ -113,9 +113,9 @@ withPeerResources v conf logger inner = withSocket conf $ \(conf', sock) -> do
     let logger' = addLabel ("host", shortPeerInfo (_peerInfo peer)) logger
         mgrLogger = setComponent "connection-manager" logger'
     withPeerDb_ v conf' $ \peerDb -> do
-        let cert = _peerCertificate peer
+        let certChain = _peerCertificateChain peer
             key = _peerKey peer
-        withConnectionManger mgrLogger cert key peerDb $ \mgr -> do
+        withConnectionManger mgrLogger certChain key peerDb $ \mgr -> do
             inner logger' (PeerResources conf' peer sock peerDb mgr logger')
 
 peerServerSettings :: Peer -> Settings
@@ -161,13 +161,13 @@ withPeerDb_ v conf = bracket (startPeerDb_ v conf) (stopPeerDb conf)
 withConnectionManger
     :: Logger logger
     => logger
-    -> X509CertPem
+    -> X509CertChainPem
     -> X509KeyPem
     -> PeerDb
     -> (HTTP.Manager -> IO a)
     -> IO a
-withConnectionManger logger cert key peerDb runInner = do
-    let cred = unsafeMakeCredential cert key
+withConnectionManger logger certs key peerDb runInner = do
+    let cred = unsafeMakeCredential certs key
     settings <- certificateCacheManagerSettings
         (TlsSecure True certCacheLookup)
         (Just cred)

src/Chainweb/RestAPI.hs

@@ -256,16 +256,16 @@ serveChainwebSocketTls
     => FromJSON t
     => PayloadCas cas
     => Settings
-    -> X509CertPem
+    -> X509CertChainPem
     -> X509KeyPem
     -> Socket
     -> ChainwebVersion
     -> ChainwebServerDbs t logger cas
     -> IO ()
-serveChainwebSocketTls settings certBytes keyBytes sock v dbs
+serveChainwebSocketTls settings certChain key sock v dbs
     = runTLSSocket tlsSettings settings sock app
   where
-    tlsSettings = tlsServerSettings certBytes keyBytes
+    tlsSettings = tlsServerChainSettings certChain key
     app = chainwebApplication v dbs
 
 serveChainwebSocketTlsEkg

src/Network/X509/SelfSigned.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -43,6 +44,7 @@ module Network.X509.SelfSigned
 
 -- * Server Settings
 , tlsServerSettings
+, tlsServerChainSettings
 
 -- * Low level Utils
 
@@ -80,6 +82,13 @@ module Network.X509.SelfSigned
 , validateX509KeyPem
 , decodePemX509Key
 
+-- ** PEM encode certificate chain
+, X509CertChainPem(..)
+, x509CertChainPemToText
+, x509CertChainPemFromText
+, pX509CertChainPem
+, unsafeX509CertChainPemFromText
+, validateX509CertChainPem
 ) where
 
 import Configuration.Utils
@@ -107,11 +116,13 @@ import Data.ASN1.Types
 import Data.Bifunctor
 import Data.ByteArray (ByteArray, convert)
 import qualified Data.ByteString as B (ByteString, length, pack)
-import qualified Data.ByteString.Char8 as B8 (unpack)
+import qualified Data.ByteString.Char8 as B8
 import Data.Default (def)
+import Data.Foldable
 import Data.Foldable (toList)
 import Data.Hashable
 import Data.Hourglass (DateTime, durationHours, timeAdd)
+import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe (maybeToList)
 import Data.PEM (PEM(..), pemParseBS, pemWriteBS)
@@ -132,7 +143,7 @@ import Network.HTTP.Client (ManagerSettings)
 import Network.HTTP.Client.TLS (mkManagerSettings)
 import Network.TLS hiding (HashSHA256, HashSHA512, SHA512)
 import Network.TLS.Extra (ciphersuite_default)
-import Network.Wai.Handler.WarpTLS as WARP (TLSSettings(..), tlsSettingsMemory)
+import Network.Wai.Handler.WarpTLS as WARP (TLSSettings(..), tlsSettingsMemory, tlsSettingsChainMemory)
 
 import Numeric.Natural (Natural)
 
@@ -626,11 +637,13 @@ generateLocalhostCertificate days
 
 -- | Create a client credential for a certificate
 --
-unsafeMakeCredential :: HasCallStack => X509CertPem -> X509KeyPem -> Credential
-unsafeMakeCredential (X509CertPem certBytes) (X509KeyPem keyBytes) =
-    case credentialLoadX509FromMemory certBytes keyBytes of
+unsafeMakeCredential :: HasCallStack => X509CertChainPem -> X509KeyPem -> Credential
+unsafeMakeCredential (X509CertChainPem cert chain) (X509KeyPem keyBytes) =
+    case credentialLoadX509ChainFromMemory (x509Bytes cert) (x509Bytes <$> chain) keyBytes of
         Left e -> error $ "failed to read certificate or key: " <> e
         Right x -> x
+  where
+    x509Bytes (X509CertPem bytes) = bytes
 
 -- | A certificate policy for using self-signed certifcates with a connection
 -- manager
@@ -714,3 +727,86 @@ tlsServerSettings (X509CertPem certBytes) (X509KeyPem keyBytes)
         , tlsAllowedVersions = [TLS13, TLS12, TLS11, TLS10]
 #endif
         }
+
+-- | TLS server settings
+--
+tlsServerChainSettings
+    :: X509CertChainPem
+    -> X509KeyPem
+    -> WARP.TLSSettings
+tlsServerChainSettings (X509CertChainPem cert chain) (X509KeyPem keyBytes)
+    = (tlsSettingsChainMemory (x509Bytes cert) (x509Bytes <$> chain) keyBytes)
+        { tlsCiphers = ciphersuite_default
+#if WITH_TLS13
+        , tlsAllowedVersions = [TLS13, TLS12, TLS11, TLS10]
+#endif
+        }
+  where
+    x509Bytes (X509CertPem bytes) = bytes
+
+-- -------------------------------------------------------------------------- --
+-- Split Certificate Chain into the head and the remaining certificats
+
+pattern CertHeader :: B8.ByteString
+pattern CertHeader = "-----BEGIN CERTIFICATE-----"
+
+takeCert :: MonadThrow m => [B8.ByteString] -> m ([B8.ByteString], [B8.ByteString])
+takeCert (CertHeader : t) = return $ first (CertHeader :) $ L.break (== CertHeader) t
+takeCert _ = throwM $ DecodeException "failed to decode X509 PEM certificate. Missing header."
+
+parseCerts :: MonadThrow m => B8.ByteString -> m [B8.ByteString]
+parseCerts bytes = go (B8.lines bytes)
+  where
+    go [] = return []
+    go l = do
+        (h, t) <- takeCert l
+        (B8.intercalate "\n" h :) <$> go t
+
+parseCertChain :: MonadThrow m => B8.ByteString -> m X509CertChainPem
+parseCertChain bytes = parseCerts bytes >>= \case
+    [] -> throwM $ DecodeException "certificate must have at least one certificate"
+    (h : t) -> return $ X509CertChainPem (X509CertPem h) (X509CertPem <$> t)
+
+data X509CertChainPem = X509CertChainPem X509CertPem ![X509CertPem]
+    deriving (Show, Eq, Ord, Generic, NFData)
+
+x509CertChainPemToText :: X509CertChainPem -> T.Text
+x509CertChainPemToText (X509CertChainPem a b) = T.intercalate "\n"
+    $ x509CertPemToText a
+    : (x509CertPemToText <$> b)
+{-# INLINE x509CertChainPemToText #-}
+
+x509CertChainPemFromText :: MonadThrow m => T.Text -> m X509CertChainPem
+x509CertChainPemFromText = parseCertChain . T.encodeUtf8
+{-# INLINE x509CertChainPemFromText #-}
+
+unsafeX509CertChainPemFromText :: HasCallStack => String -> X509CertChainPem
+unsafeX509CertChainPemFromText = unsafeFromText . T.pack
+{-# INLINE unsafeX509CertChainPemFromText #-}
+
+instance HasTextRepresentation X509CertChainPem where
+    toText = x509CertChainPemToText
+    {-# INLINE toText #-}
+    fromText = x509CertChainPemFromText
+    {-# INLINE fromText #-}
+
+instance ToJSON X509CertChainPem where
+    toJSON = toJSON . toText
+    {-# INLINE toJSON #-}
+
+instance FromJSON X509CertChainPem where
+    parseJSON = parseJsonFromText "X509CertChainPem"
+    {-# INLINE parseJSON #-}
+
+pX509CertChainPem :: Maybe String -> OptionParser X509CertChainPem
+pX509CertChainPem service = textOption
+    % prefixLong service "certificate-chain"
+    <> suffixHelp service "PEM encoded X509 certificate or certificate chain of the local peer"
+{-# INLINE pX509CertChainPem #-}
+
+validateX509CertChainPem :: MonadError T.Text m => X509CertChainPem -> m ()
+validateX509CertChainPem (X509CertChainPem a b)  =
+    case traverse_ decodePemX509Cert (a : b) of
+        Left e -> throwError $ sshow e
+        Right () -> return ()
+

src/P2P/Peer.hs

@@ -42,7 +42,7 @@ module P2P.Peer
 , PeerConfig(..)
 , peerConfigAddr
 , peerConfigInterface
-, peerConfigCertificate
+, peerConfigCertificateChain
 , peerConfigKey
 , defaultPeerConfig
 , _peerConfigPort
@@ -56,7 +56,7 @@ module P2P.Peer
 , Peer(..)
 , peerInfo
 , peerInterface
-, peerCertificate
+, peerCertificateChain
 , peerKey
 , unsafeCreatePeer
 
@@ -256,8 +256,8 @@ data PeerConfig = PeerConfig
         -- ^ The network interface that the peer binds to. Default is to
         -- bind to all available interfaces ('*').
 
-    , _peerConfigCertificate :: !(Maybe X509CertPem)
-        -- ^ The X509 certificate of the peer. If this is Nothing a new ephemeral
+    , _peerConfigCertificateChain :: !(Maybe X509CertChainPem)
+        -- ^ The X509 certificate chain of the peer. If this is Nothing a new ephemeral
         -- certificate is generated on startup and discarded on exit.
 
     , _peerConfigKey :: !(Maybe X509KeyPem)
@@ -287,30 +287,30 @@ defaultPeerConfig :: PeerConfig
 defaultPeerConfig = PeerConfig
     { _peerConfigAddr = HostAddress localhost 0
     , _peerConfigInterface = fromString "*"
-    , _peerConfigCertificate = Nothing
+    , _peerConfigCertificateChain = Nothing
     , _peerConfigKey = Nothing
     }
 
 instance ToJSON PeerConfig where
     toJSON o = object
         [ "hostaddress" .= _peerConfigAddr o
         , "interface" .= hostPreferenceToText (_peerConfigInterface o)
-        , "certificate" .= _peerConfigCertificate o
+        , "certificateChain" .= _peerConfigCertificateChain o
         , "key" .= _peerConfigKey o
         ]
 
 instance FromJSON PeerConfig where
     parseJSON = withObject "PeerConfig" $ \o -> PeerConfig
         <$> o .: "hostaddress"
         <*> (parseJsonFromText "interface" =<< o .: "interface")
-        <*> o .: "certificate"
+        <*> o .: "certificateChain"
         <*> o .: "key"
 
 instance FromJSON (PeerConfig -> PeerConfig) where
     parseJSON = withObject "PeerConfig" $ \o -> id
         <$< peerConfigAddr %.: "hostaddress" % o
         <*< setProperty peerConfigInterface "interface" (parseJsonFromText "interface") o
-        <*< peerConfigCertificate ..: "certificate" % o
+        <*< peerConfigCertificateChain ..: "certificateChain" % o
         <*< peerConfigKey ..: "key" % o
 
 pPeerConfig :: Maybe String -> MParser PeerConfig
@@ -319,7 +319,7 @@ pPeerConfig service = id
     <*< peerConfigInterface .:: textOption
         % prefixLong service "interface"
         <> suffixHelp service "interface that the Rest API binds to (see HostPreference documentation for details)"
-    <*< peerConfigCertificate .:: fmap Just % pX509CertPem service
+    <*< peerConfigCertificateChain .:: fmap Just % pX509CertChainPem service
     <*< peerConfigKey .:: fmap Just % pX509KeyPem service
 {-# INLINE pPeerConfig #-}
 
@@ -332,7 +332,7 @@ data Peer = Peer
     { _peerInfo :: !PeerInfo
         -- ^ The peer id is the SHA256 fingerprint of the certificate
     , _peerInterface :: !HostPreference
-    , _peerCertificate :: !X509CertPem
+    , _peerCertificateChain :: !X509CertChainPem
     , _peerKey :: !X509KeyPem
     }
     deriving (Show, Eq, Ord, Generic)
@@ -341,17 +341,20 @@ makeLenses ''Peer
 
 unsafeCreatePeer :: HasCallStack => PeerConfig -> IO Peer
 unsafeCreatePeer conf = do
-    (fp, cert, key) <- case (_peerConfigCertificate conf, _peerConfigKey conf) of
-        (Nothing, _) -> generateSelfSignedCertificate @DefCertType 365 dn Nothing
-        (Just c, Just k) -> return (unsafeFingerprintPem c, c, k)
+    (fp, certs, key) <- case (_peerConfigCertificateChain conf, _peerConfigKey conf) of
+        (Nothing, _) -> do
+            (fp, c, k) <- generateSelfSignedCertificate @DefCertType 365 dn Nothing
+            return (fp, X509CertChainPem c [], k)
+        (Just c@(X509CertChainPem a _), Just k) ->
+            return (unsafeFingerprintPem a, c, k)
         _ -> error "missing certificate key in peer config"
     return $ Peer
         { _peerInfo = PeerInfo
             { _peerId = Just $ peerIdFromFingerprint fp
             , _peerAddr = _peerConfigAddr conf
             }
         , _peerInterface = _peerConfigInterface conf
-        , _peerCertificate = cert
+        , _peerCertificateChain = certs
         , _peerKey = key
         }
   where
@@ -361,7 +364,7 @@ instance ToJSON Peer where
     toJSON p = object
         [ "info" .= _peerInfo p
         , "interface" .= hostPreferenceToText (_peerInterface p)
-        , "certifcate" .= _peerCertificate p
+        , "certifcateChain" .= _peerCertificateChain p
         , "key" .= _peerKey p
         ]
     {-# INLINE toJSON #-}
@@ -431,13 +434,13 @@ testnetBootstrapHost = unsafeHostnameFromText "https://us1.chainweb.com"
 instance Arbitrary PeerConfig where
     arbitrary = do
         (c, k) <- oneof
-            [ return (Just certRsa, Just keyRsa)
-            , return (Just certEd25519, Just keyEd25519)
+            [ return (Just (X509CertChainPem certRsa []), Just keyRsa)
+            , return (Just (X509CertChainPem certEd25519 []), Just keyEd25519)
             , return (Nothing, Nothing)
             ]
         PeerConfig
             <$> arbitrary
-            <*> oneof (return <$> ["0.0.0.0", "127.0.0.1", "*", "*4", "!4", "*6", "!6"])
+            <*> oneof (return <$> ["0.0.0.0", "127.0.0.1", "::1", "*", "*4", "!4", "*6", "!6"])
             <*> return c
             <*> return k
       where

test/Chainweb/Test/P2P/Peer/BootstrapConfig.hs

@@ -47,7 +47,7 @@ testBootstrapPeerConfig v =
     [ PeerConfig
         { _peerConfigAddr = _peerAddr $ head (bootstrapPeerInfos v)
         , _peerConfigInterface = "127.0.0.1"
-        , _peerConfigCertificate = Just $ bootstrapCertificate v
+        , _peerConfigCertificateChain = Just $ X509CertChainPem (bootstrapCertificate v) []
         , _peerConfigKey = Just $ bootstrapKey v
         }
     ]

test/Network/X509/SelfSigned/Test.hs

@@ -63,7 +63,7 @@ testCertType l = testCaseSteps l $ \step -> do
     step "Generate Certificate"
 
     (fp, cert, key) <- generateLocalhostCertificate @k 1
-    let cred = unsafeMakeCredential cert key
+    let cred = unsafeMakeCredential (X509CertChainPem cert []) key
 
     step "Start Server"
     bracket openFreePort (close . snd) $ \(p, sock) -> do