Index consistency check uses better checkpoints

src/cddl-test/Main.hs

@@ -102,7 +102,7 @@ dbArgs fp = do
     , immErr            = EH.exceptions
     , immEpochInfo      = epochInfo
     , immValidation     = ValidateMostRecentEpoch
-    , immIsEBB          = isEBB
+    , immIsEBB          = fmap fst . isEBB
     , immAddHdrEnv      = Byron.byronAddHeaderEnvelope
     , immCheckIntegrity = const True -- No validation
     , immHasFS          = ioHasFS $ MountPoint (fp </> "immutable")

src/exec/Byron.hs

@@ -22,7 +22,6 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe (mapMaybe)
 import qualified Data.Text.Lazy.Builder as Text
-import Data.Word (Word64)
 import System.Random (StdGen, getStdGen, randomR)
 
 import qualified Cardano.Binary as Binary
@@ -34,14 +33,14 @@ import qualified Pos.Chain.Block as CSL (Block, BlockHeader (..), GenesisBlock,
                                          MainBlockHeader, HeaderHash, headerHash)
 import qualified Pos.Infra.Diffusion.Types as CSL
 
-import Ouroboros.Byron.Proxy.Block (ByronBlock,
+import Ouroboros.Byron.Proxy.Block (ByronBlock, checkpointOffsets,
          coerceHashToLegacy, headerHash)
 import Ouroboros.Byron.Proxy.Main
 import Ouroboros.Consensus.Block (Header)
 import Ouroboros.Consensus.Ledger.Byron (ByronHash(..),
          byronHeaderRaw, mkByronBlock)
 import Ouroboros.Consensus.Ledger.Byron.Auxiliary as Cardano
-import Ouroboros.Consensus.Protocol.Abstract (SecurityParam (maxRollbacks))
+import Ouroboros.Consensus.Protocol.Abstract (SecurityParam)
 import Ouroboros.Network.Block (ChainHash (..), Point, pointHash)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import qualified Ouroboros.Network.ChainFragment as CF
@@ -136,25 +135,14 @@ download tracer genesisBlock epochSlots securityParam db bp = do
   checkpoints
     :: AF.AnchoredFragment (Header ByronBlock)
     -> [CSL.HeaderHash]
-  checkpoints = mapMaybe pointToHash . AF.selectPoints (fmap fromIntegral offsets)
+  checkpoints = mapMaybe pointToHash .
+    AF.selectPoints (fmap fromIntegral (checkpointOffsets securityParam))
 
   pointToHash :: Point (Header ByronBlock) -> Maybe CSL.HeaderHash
   pointToHash pnt = case pointHash pnt of
     GenesisHash                -> Nothing
     BlockHash (ByronHash hash) -> Just $ coerceHashToLegacy hash
 
-  -- Offsets for selectPoints. Defined in the same way as for the Shelley
-  -- chain sync client: fibonacci numbers including 0 and k.
-  offsets :: [Word64]
-  offsets = 0 : foldr includeK ([] {- this is never forced -}) (tail fibs)
-
-  includeK :: Word64 -> [Word64] -> [Word64]
-  includeK w ws | w >= k    = [k]
-                | otherwise = w : ws
-
-  fibs :: [Word64]
-  fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
-
   streamer :: CSL.HeaderHash -> CSL.StreamBlocks CSL.Block IO CSL.HeaderHash
   streamer tipHash = CSL.StreamBlocks
     { CSL.streamBlocksMore = \blocks -> do
@@ -188,9 +176,6 @@ download tracer genesisBlock epochSlots securityParam db bp = do
     let (idx, rndGen') = randomR (0, NE.length ne - 1) rndGen
     in  (ne NE.!! idx, rndGen')
 
-  k :: Word64
-  k = maxRollbacks securityParam
-
 recodeBlockOrFail
   :: Cardano.EpochSlots
   -> (forall x . Binary.DecoderError -> IO x)

src/exec/DB.hs

@@ -23,10 +23,11 @@ import           Ouroboros.Consensus.BlockchainTime        (BlockchainTime)
 import           Ouroboros.Consensus.Ledger.Byron.Config   (pbftEpochSlots)
 import           Ouroboros.Consensus.Ledger.Extended       (ExtLedgerState)
 import           Ouroboros.Consensus.Node                  (withChainDB)
-import           Ouroboros.Consensus.Protocol              (NodeConfig,
-                                                            pbftExtConfig)
 import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
 import qualified Ouroboros.Consensus.Util.ResourceRegistry as ResourceRegistry
+import           Ouroboros.Consensus.Protocol              (NodeConfig,
+                                                            pbftExtConfig)
+import           Ouroboros.Consensus.Protocol.Abstract     (protocolSecurityParam)
 import           Ouroboros.Storage.ChainDB.API             (ChainDB)
 import qualified Ouroboros.Storage.ChainDB.Impl            as ChainDB
 import           Ouroboros.Storage.ChainDB.Impl.Args       (ChainDbArgs (..))
@@ -61,7 +62,7 @@ withDB dbOptions dbTracer indexTracer rr btime nodeConfig extLedgerState k = do
   withChainDB dbTracer rr btime (dbFilePath dbOptions) nodeConfig extLedgerState customiseArgs
     $ \cdb ->
       Sqlite.withIndexAuto epochSlots indexTracer (indexFilePath dbOptions) $ \idx -> do
-        _ <- ResourceRegistry.forkLinkedThread rr $ Index.trackChainDB rr idx cdb
+        _ <- ResourceRegistry.forkLinkedThread rr $ Index.trackChainDB rr idx cdb (protocolSecurityParam nodeConfig)
         k idx cdb
 
   where

src/exec/Main.hs

@@ -55,7 +55,6 @@ import qualified Pos.Infra.Network.CLI as CSL (NetworkConfigOpts (..),
                                                launchStaticConfigMonitoring,
                                                listenNetworkAddressOption)
 import Pos.Infra.Network.Types (NetworkConfig (..))
-import qualified Pos.Infra.Network.Policy as Policy
 import qualified Pos.Launcher.Configuration as CSL (Configuration (..),
                                                     ConfigurationOptions (..))
 import qualified Pos.Client.CLI.Options as CSL (configurationOptionsParser)
@@ -491,17 +490,13 @@ runByron tracer byronOptions genesisConfig blockConfig updateConfig nodeConfig e
     networkConfig <- CSL.intNetworkConfigOpts
       (Trace.named cslTrace)
       (boNetworkOptions byronOptions)
-    let networkConfig' = networkConfig
-          { ncEnqueuePolicy = Policy.defaultEnqueuePolicyRelay
-          , ncDequeuePolicy = Policy.defaultDequeuePolicyRelay
-          }
-        bpc :: ByronProxyConfig
+    let bpc :: ByronProxyConfig
         bpc = configFromCSLConfigs
                 genesisConfig
                 blockConfig
                 updateConfig
                 nodeConfig
-                networkConfig'
+                networkConfig
                 64 -- Batch size.
                 trace
         genesisBlock = CSL.genesisBlock0 (CSL.configProtocolMagic genesisConfig)

src/lib/Ouroboros/Byron/Proxy/Block.hs

@@ -19,9 +19,11 @@ module Ouroboros.Byron.Proxy.Block
   , coerceHashToLegacy
   , headerHash
   , isEBB
+  , checkpointOffsets
   ) where
 
 import qualified Codec.CBOR.Write as CBOR (toStrictByteString)
+import Data.Word (Word64)
 
 import qualified Pos.Chain.Block as CSL (HeaderHash)
 import qualified Pos.Crypto.Hashing as Legacy (AbstractHash (..))
@@ -31,8 +33,9 @@ import qualified Cardano.Chain.Block as Cardano
 import Cardano.Crypto.Hashing (AbstractHash (..))
 
 import qualified Ouroboros.Consensus.Block as Consensus (GetHeader (..))
-import Ouroboros.Consensus.Ledger.Byron (ByronBlock (..), ByronHash (..),
-         encodeByronBlock, byronHeaderHash)
+import Ouroboros.Consensus.Ledger.Byron (ByronBlock (..),
+         ByronHash (..), encodeByronBlock, byronHeaderHash)
+import Ouroboros.Consensus.Protocol.Abstract (SecurityParam (..))
 import Ouroboros.Storage.Common (EpochNo(..))
 
 -- For type instance HeaderHash (Header blk) = HeaderHash blk
@@ -60,11 +63,23 @@ headerHash = unByronHash . byronHeaderHash
 
 -- | Return @Just@ the epoch number if the block is an EBB, @Nothing@ for
 -- regular blocks
-isEBB :: ByronBlock -> Maybe EpochNo
+isEBB :: ByronBlock -> Maybe (EpochNo, ByronHash)
 isEBB blk = case byronBlockRaw blk of
     Cardano.ABOBBlock _      -> Nothing
-    Cardano.ABOBBoundary ebb -> Just
-                              . EpochNo
-                              . Cardano.boundaryEpoch
-                              . Cardano.boundaryHeader
-                              $ ebb
+    Cardano.ABOBBoundary ebb -> Just (epochNo, byronHash)
+      where
+      epochNo = EpochNo . Cardano.boundaryEpoch . Cardano.boundaryHeader $ ebb
+      byronHash = ByronHash . headerHash . Consensus.getHeader $ blk
+
+-- | Compute the offsets for use by ChainFragment.selectPoints or
+-- AnchoredFragment.selectPoints for some security parameter k. It uses
+-- fibonacci numbers with 0 and k as endpoints, and the duplicate 1 at the
+-- start removed.
+checkpointOffsets :: SecurityParam -> [Word64]
+checkpointOffsets (SecurityParam k) = 0 : foldr includeK ([] {- this is never forced -}) (tail fibs)
+  where
+    includeK :: Word64 -> [Word64] -> [Word64]
+    includeK w ws | w >= k    = [k]
+                  | otherwise = w : ws
+    fibs :: [Word64]
+    fibs = 1 : 1 : zipWith (+) fibs (tail fibs)

src/lib/Ouroboros/Byron/Proxy/Genesis/Convert.hs

@@ -1,3 +1,14 @@
+{-|
+Module      : Ouroboros.Byron.Proxy.Genesis.Convert
+Description : Conversion of legacy cardano-sl genesis configuration.
+
+cardano-byron-proxy must use legacy cardano-sl genesis configuration in order
+to run the Byron side, and must also use a similar configuration to set up
+the Shelley side. The definitions in this module convert values of legacy Byron
+configuration types (cardano-sl) into their corresponding new Shelley
+types (cardano-ledger).
+-}
+
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GADTSyntax #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -8,8 +19,6 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE PatternSynonyms #-}
 
-{-# LANGUAGE TypeFamilies #-}
-
 module Ouroboros.Byron.Proxy.Genesis.Convert where
 
 import Data.Coerce (coerce)
@@ -196,7 +205,6 @@ convertProtocolParameters bvd = Cardano.ProtocolParameters
   , Cardano.ppUnlockStakeEpoch = convertEpochIndex (CSL.bvdUnlockStakeEpoch bvd)
   }
 
-
 convertGenesisSpec :: CSL.GenesisSpec -> Cardano.GenesisSpec
 convertGenesisSpec gspec = Cardano.UnsafeGenesisSpec
   { Cardano.gsAvvmDistr = convertAvvmDistr (CSL.gsAvvmDistr gspec)

src/lib/Ouroboros/Byron/Proxy/Index/ChainDB.hs

@@ -6,13 +6,16 @@ module Ouroboros.Byron.Proxy.Index.ChainDB
   ) where
 
 import Control.Exception (bracket)
+import Data.Word (Word64)
 
+import Ouroboros.Byron.Proxy.Block (checkpointOffsets)
 import Ouroboros.Byron.Proxy.Index.Types (Index)
 import qualified Ouroboros.Byron.Proxy.Index.Types as Index
 import Ouroboros.Consensus.Block (GetHeader (Header))
 import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
+import Ouroboros.Consensus.Protocol.Abstract (SecurityParam)
 import Ouroboros.Network.Block (ChainUpdate (..), Point (..))
-import Ouroboros.Network.Point (WithOrigin (Origin))
+import Ouroboros.Network.Point (WithOrigin (Origin), block)
 import Ouroboros.Storage.ChainDB.API (ChainDB, Reader)
 import qualified Ouroboros.Storage.ChainDB.API as ChainDB
 
@@ -21,7 +24,7 @@ trackReaderBlocking
   :: ( Monad m )
   => Index m (Header blk)
   -> Reader m blk (Header blk)
-  -> m x
+  -> m void
 trackReaderBlocking idx reader = do
   instruction <- ChainDB.readerInstructionBlocking reader
   case instruction of
@@ -50,42 +53,60 @@ trackReader idx reader = do
       trackReader idx reader
     Nothing -> pure ()
 
--- | Have an Index track a ChainDB using its Reader API. You probably want to
--- race this with some other thread that runs your application.
+-- | Have an Index track a ChainDB using its Reader API.
 --
--- If the ChainDB does not contain the tip of the Index, then the whole index
--- will be rebuilt.
---
--- It will spawn a thread to do the index updates. This must be the only
--- index writer. It is run by `race` with the action, so exceptions in either
--- the action or the writer thread will be re-thrown here.
---
--- If the tip of the index is not in the ChainDB, then the entire index will be
--- rebuilt. This is not ideal: there may be an intersection. TODO would be
--- better to check the newest slot older than `k` back from tip of index, and
--- go from there.
+-- If the tip of the index is in the ChainDB, then no work must be done in the
+-- beginning. But if it's not in the ChainDB, there will have to be a rollback
+-- on the index. The SecurityParam k is used to decide how far back to try. If
+-- Only index entries at most k slots old will be checked against the
+-- ChainDB. If none are in it, then the entire index will be rebuild (rollback
+-- to Origin).
 trackChainDB
   :: forall blk void .
      ResourceRegistry IO
   -> Index IO (Header blk)
   -> ChainDB IO blk
+  -> SecurityParam
   -> IO void
-trackChainDB rr idx cdb = bracket acquireReader releaseReader $ \rdr -> do
-  tipPoint <- Index.tip idx
-  mPoint <- ChainDB.readerForward rdr [Point tipPoint]
-  -- `readerForward` docs say that if we get `Nothing`, the next reader
-  -- instruction may not be a rollback, so we'll manually roll the index
-  -- back. It's assumed the read pointer will be at origin (nothing else
-  -- would make sense).
-  case mPoint of
-    Nothing -> Index.rollbackward idx Origin
-    Just _  -> pure ()
-  -- First, block until the index is caught up to the tip ...
-  trackReader idx rdr
-  -- ... then attempt to stay in sync.
-  trackReaderBlocking idx rdr
+trackChainDB rr idx cdb k = bracket acquireReader releaseReader $ \rdr -> do
+    checkpoints <- Index.streamFromTip idx checkpointsFold
+    mPoint <- ChainDB.readerForward rdr checkpoints
+    case mPoint of
+      -- `readerForward` docs say that the next instruction will be a rollback,
+      -- so we don't have to do anything here; the call to `trackReader` will
+      -- do what needs to be done.
+      Just _  -> pure ()
+      -- `readerForward` docs say that if we get `Nothing`, the next reader
+      -- instruction may not be a rollback, so we'll manually roll the index
+      -- back. It's assumed the read pointer will be at origin (nothing else
+      -- would make sense).
+      Nothing -> Index.rollbackward idx Origin
+    -- First, block until the index is caught up to the tip ...
+    trackReader idx rdr
+    -- ... then attempt to stay in sync.
+    trackReaderBlocking idx rdr
   where
   acquireReader :: IO (Reader IO blk (Header blk))
   acquireReader = ChainDB.deserialiseReader <$> ChainDB.newHeaderReader cdb rr
   releaseReader :: Reader IO blk (Header blk) -> IO ()
   releaseReader = ChainDB.readerClose
+
+  checkpointsFold :: Index.Fold (Header blk) [Point blk]
+  checkpointsFold = checkpointsFoldN 0 (checkpointOffsets k)
+
+  -- Count up from 0 on the first parameter. Whenever it coincides with the
+  -- head of the second parameter (an increasing list) include that point.
+  -- Stop when the second list is empty.
+  -- Since checkpointsFold always includes the paramater k, the k'th entry
+  -- in the index will always be in here, unless the index is shorter
+  -- than k. This block is _at least_ k slots behind the DB, so if it's not
+  -- in the DB then the index is way out of date.
+  checkpointsFoldN
+    :: Word64
+    -> [Word64]
+    -> Index.Fold (Header blk) [Point blk]
+  checkpointsFoldN _ []       = Index.Stop []
+  checkpointsFoldN w (o : os) = Index.More [] $ \slotNo hash ->
+    if w == o
+    then fmap ((:) (Point (block slotNo hash))) (checkpointsFoldN (w+1) os)
+    else checkpointsFoldN (w+1) (o : os)