Optionally support lightweight checkpointing

bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs

@@ -42,15 +42,15 @@ getGenesis (SomeConsensusProtocol CardanoBlockType proto)
 getGenesisPath :: NodeConfiguration -> Maybe GenesisFile
 getGenesisPath nodeConfig =
   case ncProtocolConfig nodeConfig of
-    NodeProtocolConfigurationCardano _ shelleyConfig _ _ _ ->
+    NodeProtocolConfigurationCardano _ shelleyConfig _ _ _ _ ->
       Just $ npcShelleyGenesisFile shelleyConfig
 
 mkConsensusProtocol :: NodeConfiguration -> IO (Either TxGenError SomeConsensusProtocol)
 mkConsensusProtocol nodeConfig =
   case ncProtocolConfig nodeConfig of
-    NodeProtocolConfigurationCardano byronConfig shelleyConfig alonzoConfig conwayConfig hardforkConfig ->
+    NodeProtocolConfigurationCardano byronConfig shelleyConfig alonzoConfig conwayConfig hardforkConfig checkpointsConfig ->
       first ProtocolError
-        <$> runExceptT (mkSomeConsensusProtocolCardano byronConfig shelleyConfig alonzoConfig conwayConfig hardforkConfig Nothing)
+        <$> runExceptT (mkSomeConsensusProtocolCardano byronConfig shelleyConfig alonzoConfig conwayConfig hardforkConfig checkpointsConfig Nothing)
 
 -- | Creates a NodeConfiguration from a config file;
 --   the result is devoid of any keys/credentials

cardano-node/ChangeLog.md

@@ -12,6 +12,29 @@
 
 - Use metric names of old-tracing in new-tracing as well, and fix some metrics in new tracing.
 
+- Optionally support lightweight checkpointing.
+
+  This PR adds optional support for *lightweight checkpointing*. Concretely, a file can contain a list of checkpoints (each consisting of a block number and a corresponding block hash). When validating a header/block with a block number with a corresponding checkpoint, we consider the header/block to be invalid if their actual hash does not coincide with the hash from the checkpoint.
+
+  This is only expected to be used in certain disaster recovery scenarios, so ideally never. See [CIP-0135](https://github.com/cardano-foundation/CIPs/blob/master/CIP-0135/README.md) for more details.
+
+  > ⚠️ Specifying a checkpoints file requires great care; incorrect entries can lead the node to be stuck on adversarial chains forever!
+
+  Concretely, the node configuration file has two new optional entries:
+  ```yaml
+  CheckpointsFile: "/path/to/checkpoints.json"
+  CheckpointsFileHash: "a71c47262163947daaefb6aa1112acf34cb5ded6841d51e27dd642eb2de355a3"
+  ```
+
+  The `checkpoints.json` file has the following format:
+  ```json
+  {
+    "checkpoints": [
+      {"blockNo": 3, "hash": "52b7912de176ab76c233d6e08ccdece53ac1863c08cc59d3c5dec8d924d9b536"}
+    ]
+  }
+  ```
+
 ## 8.2.1 -- August 2023
 
 - prevent SIGHUP from killing node during ledger replay

cardano-node/cardano-node.cabal

@@ -82,6 +82,7 @@ library
                         Cardano.Node.Protocol.Alonzo
                         Cardano.Node.Protocol.Byron
                         Cardano.Node.Protocol.Cardano
+                        Cardano.Node.Protocol.Checkpoints
                         Cardano.Node.Protocol.Conway
                         Cardano.Node.Protocol.Shelley
                         Cardano.Node.Protocol.Types

cardano-node/src/Cardano/Node/Configuration/POM.hs

@@ -289,6 +289,7 @@ instance FromJSON PartialNodeConfiguration where
                 <*> parseAlonzoProtocol v
                 <*> parseConwayProtocol v
                 <*> parseHardForkProtocol v
+                <*> parseCheckpoints v
       pncMaybeMempoolCapacityOverride <- Last <$> parseMempoolCapacityBytesOverride v
 
       -- Network timeouts
@@ -489,6 +490,14 @@ instance FromJSON PartialNodeConfiguration where
           , npcTestConwayHardForkAtVersion
           }
 
+      parseCheckpoints v = do
+        npcCheckpointsFile     <- v .:? "CheckpointsFile"
+        npcCheckpointsFileHash <- v .:? "CheckpointsFileHash"
+        pure NodeCheckpointsConfiguration
+          { npcCheckpointsFile
+          , npcCheckpointsFileHash
+          }
+
 -- | Default configuration is mainnet
 defaultPartialNodeConfiguration :: PartialNodeConfiguration
 defaultPartialNodeConfiguration =

cardano-node/src/Cardano/Node/Protocol.hs

@@ -30,14 +30,16 @@ mkConsensusProtocol ncProtocolConfig mProtocolFiles =
         shelleyConfig
         alonzoConfig
         conwayConfig
-        hardForkConfig ->
+        hardForkConfig
+        checkpointsConfig ->
       firstExceptT CardanoProtocolInstantiationError $
         mkSomeConsensusProtocolCardano
           byronConfig
           shelleyConfig
           alonzoConfig
           conwayConfig
           hardForkConfig
+          checkpointsConfig
           mProtocolFiles
 
 ------------------------------------------------------------------------------

cardano-node/src/Cardano/Node/Protocol/Cardano.hs

@@ -23,6 +23,7 @@ import qualified Cardano.Ledger.Api.Transition as Ledger
 import           Cardano.Ledger.BaseTypes (natVersion)
 import qualified Cardano.Node.Protocol.Alonzo as Alonzo
 import qualified Cardano.Node.Protocol.Byron as Byron
+import           Cardano.Node.Protocol.Checkpoints
 import qualified Cardano.Node.Protocol.Conway as Conway
 import qualified Cardano.Node.Protocol.Shelley as Shelley
 import           Cardano.Node.Protocol.Types
@@ -34,7 +35,6 @@ import qualified Ouroboros.Consensus.Cardano as Consensus
 import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
 import           Ouroboros.Consensus.Cardano.Condense ()
 import qualified Ouroboros.Consensus.Cardano.Node as Consensus
-import           Ouroboros.Consensus.Config (emptyCheckpointsMap)
 import           Ouroboros.Consensus.HardFork.Combinator.Condense ()
 
 import           Prelude
@@ -61,6 +61,7 @@ mkSomeConsensusProtocolCardano
   -> NodeAlonzoProtocolConfiguration
   -> NodeConwayProtocolConfiguration
   -> NodeHardForkProtocolConfiguration
+  -> NodeCheckpointsConfiguration
   -> Maybe ProtocolFilepaths
   -> ExceptT CardanoProtocolInstantiationError IO SomeConsensusProtocol
 mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
@@ -103,6 +104,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
                              npcTestConwayHardForkAtEpoch,
                              npcTestConwayHardForkAtVersion
                            }
+                           checkpointsConfiguration
                            files = do
     byronGenesis <-
       firstExceptT CardanoProtocolInstantiationErrorByron $
@@ -140,6 +142,10 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
       firstExceptT CardanoProtocolInstantiationPraosLeaderCredentialsError $
         Shelley.readLeaderCredentials files
 
+    checkpointsMap <-
+      firstExceptT CardanoProtocolInstantiationCheckpointsReadError $
+        readCheckpointsMap checkpointsConfiguration
+
     return $!
       SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano $ Consensus.CardanoProtocolParams {
         Consensus.byronProtocolParams =
@@ -234,8 +240,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
                              (maybe 9 fromIntegral npcTestConwayHardForkAtVersion)
                 Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo
         }
-       -- TODO: once https://github.com/IntersectMBO/cardano-node/issues/5730 is implemented 'emptyCheckpointsMap' needs to be replaced with the checkpoints map read from a configuration file.
-      , Consensus.cardanoCheckpoints = emptyCheckpointsMap
+      , Consensus.cardanoCheckpoints = checkpointsMap
       }
 
         ----------------------------------------------------------------------
@@ -265,6 +270,9 @@ data CardanoProtocolInstantiationError =
 
      | CardanoProtocolInstantiationErrorAlonzo
          Alonzo.AlonzoProtocolInstantiationError
+
+     | CardanoProtocolInstantiationCheckpointsReadError
+         CheckpointsReadError
   deriving Show
 
 instance Error CardanoProtocolInstantiationError where
@@ -280,3 +288,5 @@ instance Error CardanoProtocolInstantiationError where
     prettyError err
   prettyError (CardanoProtocolInstantiationErrorAlonzo err) =
     prettyError err
+  prettyError (CardanoProtocolInstantiationCheckpointsReadError err) =
+    prettyError err

cardano-node/src/Cardano/Node/Protocol/Checkpoints.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Configuration for lightweight checkpointing.
+module Cardano.Node.Protocol.Checkpoints
+  ( CheckpointsReadError(..)
+  , readCheckpointsMap
+  ) where
+
+import           Cardano.Api
+
+import qualified Cardano.Crypto.Hash.Class as Crypto
+import           Cardano.Ledger.Crypto (StandardCrypto)
+import           Cardano.Node.Types
+import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Cardano
+import           Ouroboros.Consensus.Config (CheckpointsMap (..), emptyCheckpointsMap)
+
+import           Control.Exception (IOException)
+import           Control.Monad (forM, unless, when)
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import           Data.Foldable (forM_)
+import qualified Data.Map.Strict as Map
+import           Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+
+data CheckpointsReadError =
+       CheckpointsReadFileError !FilePath !IOException
+     | CheckpointsHashMismatch
+         !FilePath
+         -- | Actual
+         !CheckpointsHash
+         -- | Expected
+         !CheckpointsHash
+     | CheckpointsDecodeError !FilePath !String
+   deriving Show
+
+instance Error CheckpointsReadError where
+  prettyError (CheckpointsReadFileError fp err) =
+        "There was an error reading the checkpoints file: "
+     <> pshow fp <> " Error: " <> pshow err
+
+  prettyError (CheckpointsHashMismatch fp actual expected) =
+        "Hash mismatch for checkpoints file " <> pshow fp <> ": "
+     <> "the actual hash is " <> pshow actual <> ", but the expected "
+     <> "hash given in the node configuration file is " <> pshow expected
+
+  prettyError (CheckpointsDecodeError fp err) =
+        "There was an error parsing the checkpoints file: "
+     <> pshow fp <> " Error: " <> pshow err
+
+readCheckpointsMap
+  :: NodeCheckpointsConfiguration
+  -> ExceptT CheckpointsReadError IO (CheckpointsMap (CardanoBlock StandardCrypto))
+readCheckpointsMap NodeCheckpointsConfiguration {
+                       npcCheckpointsFile,
+                       npcCheckpointsFileHash = mExpectedHash
+                     } = case npcCheckpointsFile of
+    Nothing -> pure emptyCheckpointsMap
+    Just (CheckpointsFile file) -> do
+      content <-
+        handleIOExceptT (CheckpointsReadFileError file) $ BS.readFile file
+
+      let actualHash = CheckpointsHash $ Crypto.hashWith id content
+      forM_ mExpectedHash $ \expectedHash ->
+        when (actualHash /= expectedHash) $
+          throwError (CheckpointsHashMismatch file actualHash expectedHash)
+
+      WrapCheckpointsMap checkpointsMap <-
+        firstExceptT (CheckpointsDecodeError file) $ hoistEither $
+          Aeson.eitherDecodeStrict' content
+      pure checkpointsMap
+
+newtype WrapCheckpointsMap =
+        WrapCheckpointsMap (CheckpointsMap (CardanoBlock StandardCrypto))
+
+instance Aeson.FromJSON WrapCheckpointsMap where
+  parseJSON = Aeson.withObject "CheckpointsMap" $ \o -> do
+      checkpointList :: [Aeson.Object] <- o Aeson..: "checkpoints"
+
+      checkpoints :: [(BlockNo, HeaderHash (CardanoBlock StandardCrypto))] <-
+        forM checkpointList $ \c -> do
+          bno <- c Aeson..: "blockNo"
+          hash <- parseCardanoHash =<< c Aeson..: "hash"
+          pure (bno, hash)
+
+      let duplicates :: Set BlockNo
+          duplicates =
+            Map.keysSet $ Map.filter (> 1) $ Map.fromListWith (+) $
+              (\(bno, _) -> (bno, 1 :: Int)) <$> checkpoints
+      unless (Set.null duplicates) $
+        fail $ "Duplicate checkpoints for block numbers "
+            <> show (Set.toList duplicates)
+
+      pure $ WrapCheckpointsMap $ CheckpointsMap $ Map.fromList checkpoints
+    where
+      parseCardanoHash
+        :: Aeson.Value
+        -> Aeson.Parser (HeaderHash (CardanoBlock StandardCrypto))
+      parseCardanoHash = Aeson.withText "CheckpointHash" $ \t ->
+          case B16.decode $ Text.encodeUtf8 t of
+            Right h -> do
+              when (BS.length h /= fromIntegral (hashSize p)) $
+                fail $ "Invalid hash size for " <> Text.unpack t
+              pure $ fromRawHash p h
+            Left e  ->
+              fail $ "Invalid base16 for " <> Text.unpack t <> ": " <> e
+        where
+          p = Proxy @(CardanoBlock StandardCrypto)

cardano-node/src/Cardano/Node/Types.hs

@@ -14,8 +14,10 @@ module Cardano.Node.Types
   , ConfigYamlFilePath(..)
   , DbFile(..)
   , GenesisFile(..)
+  , CheckpointsFile(..)
   , ProtocolFilepaths (..)
   , GenesisHash(..)
+  , CheckpointsHash(..)
   , MaxConcurrencyBulkSync(..)
   , MaxConcurrencyDeadline(..)
     -- * Networking
@@ -29,6 +31,7 @@ module Cardano.Node.Types
   , NodeShelleyProtocolConfiguration(..)
   , NodeAlonzoProtocolConfiguration(..)
   , NodeConwayProtocolConfiguration(..)
+  , NodeCheckpointsConfiguration(..)
   , VRFPrivateKeyFilePermissionError(..)
   , renderVRFPrivateKeyFilePermissionError
   ) where
@@ -38,6 +41,7 @@ import           Cardano.Api
 import           Cardano.Crypto (RequiresNetworkMagic (..))
 import qualified Cardano.Crypto.Hash as Crypto
 import           Cardano.Node.Configuration.Socket (SocketConfig (..))
+import           Cardano.Node.Orphans ()
 import           Ouroboros.Network.NodeToNode (DiffusionMode (..))
 
 import           Control.Exception
@@ -85,6 +89,16 @@ instance FromJSON GenesisFile where
   parseJSON invalid = fail $ "Parsing of GenesisFile failed due to type mismatch. "
                           <> "Encountered: " <> show invalid
 
+newtype CheckpointsFile = CheckpointsFile
+  { unCheckpointsFile :: FilePath }
+  deriving stock (Eq, Ord)
+  deriving newtype (IsString, Show)
+
+instance FromJSON CheckpointsFile where
+  parseJSON (String genFp) = pure . CheckpointsFile $ Text.unpack genFp
+  parseJSON invalid = fail $ "Parsing of CheckpointsFile failed due to type mismatch. "
+                          <> "Encountered: " <> show invalid
+
 newtype MaxConcurrencyBulkSync = MaxConcurrencyBulkSync
   { unMaxConcurrencyBulkSync :: Word }
   deriving stock (Eq, Ord)
@@ -129,13 +143,17 @@ data ProtocolFilepaths =
 newtype GenesisHash = GenesisHash (Crypto.Hash Crypto.Blake2b_256 ByteString)
   deriving newtype (Eq, Show, ToJSON, FromJSON)
 
+newtype CheckpointsHash = CheckpointsHash (Crypto.Hash Crypto.Blake2b_256 ByteString)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
+
 data NodeProtocolConfiguration =
   NodeProtocolConfigurationCardano
     NodeByronProtocolConfiguration
     NodeShelleyProtocolConfiguration
     NodeAlonzoProtocolConfiguration
     NodeConwayProtocolConfiguration
     NodeHardForkProtocolConfiguration
+    NodeCheckpointsConfiguration
   deriving (Eq, Show)
 
 data NodeShelleyProtocolConfiguration =
@@ -287,6 +305,14 @@ data NodeHardForkProtocolConfiguration =
      }
   deriving (Eq, Show)
 
+-- | See 'Ouroboros.Consensus.Config.CheckpointsMap'.
+data NodeCheckpointsConfiguration =
+     NodeCheckpointsConfiguration {
+       npcCheckpointsFile     :: !(Maybe CheckpointsFile)
+     , npcCheckpointsFileHash :: !(Maybe CheckpointsHash)
+     }
+ deriving (Eq, Show)
+
 -- | Find the starting era for the test network, if it was configured.
 --
 -- Starting eras have zero defined as a forking epoch. So here we're taking the last zeroed configuration value.
@@ -344,13 +370,14 @@ newtype TopologyFile = TopologyFile
   deriving newtype (Show, Eq)
 
 instance AdjustFilePaths NodeProtocolConfiguration where
-  adjustFilePaths f (NodeProtocolConfigurationCardano pcb pcs pca pcc pch) =
+  adjustFilePaths f (NodeProtocolConfigurationCardano pcb pcs pca pcc pch pccp) =
     NodeProtocolConfigurationCardano
       (adjustFilePaths f pcb)
       (adjustFilePaths f pcs)
       (adjustFilePaths f pca)
       (adjustFilePaths f pcc)
       pch
+      (adjustFilePaths f pccp)
 
 instance AdjustFilePaths NodeByronProtocolConfiguration where
   adjustFilePaths f x@NodeByronProtocolConfiguration {
@@ -376,13 +403,22 @@ instance AdjustFilePaths NodeConwayProtocolConfiguration where
                       } =
     x { npcConwayGenesisFile = adjustFilePaths f npcConwayGenesisFile }
 
+instance AdjustFilePaths NodeCheckpointsConfiguration where
+  adjustFilePaths f x@NodeCheckpointsConfiguration {
+                        npcCheckpointsFile
+                      } =
+    x { npcCheckpointsFile = adjustFilePaths f npcCheckpointsFile }
+
 instance AdjustFilePaths SocketConfig where
   adjustFilePaths f x@SocketConfig{ncSocketPath} =
     x { ncSocketPath = fmap (mapFile f) ncSocketPath }
 
 instance AdjustFilePaths GenesisFile where
   adjustFilePaths f (GenesisFile p) = GenesisFile (f p)
 
+instance AdjustFilePaths CheckpointsFile where
+  adjustFilePaths f (CheckpointsFile p) = CheckpointsFile (f p)
+
 instance AdjustFilePaths a => AdjustFilePaths (Maybe a) where
   adjustFilePaths f = fmap (adjustFilePaths f)