Merge #27

27: Byron chain download uses better checkpoints r=avieth a=avieth

Previously it would use only one checkpoint: the current tip. That's fine if there are no forks, but wouldn't work if there were.

Now the checkpoints are computed in the same way as the chain sync client from ouroboros-consensus: fibonacci numbers including `0` and `k` without the duplicate `1`.

I've also included some unrelated improvements to documentation, and a commit to make configuring the Byron-side easier (using cardano-sl configurations).

Co-authored-by: Alexander Vieth <[email protected]>

Author: iohk-bors[bot]

cardano-byron-proxy.cabal

@@ -36,6 +36,7 @@ library
                        cardano-sl-crypto,
                        cardano-sl-db,
                        cardano-sl-infra,
+                       cardano-sl-util,
                        cborg,
                        conduit,
                        containers,
@@ -57,6 +58,7 @@ library
                        tagged,
                        text,
                        time,
+                       time-units,
                        transformers,
                        typed-protocols,
                        unliftio-core,

nix/.stack.nix/cardano-byron-proxy.nix

@@ -30,6 +30,7 @@
           (hsPkgs.cardano-sl-crypto)
           (hsPkgs.cardano-sl-db)
           (hsPkgs.cardano-sl-infra)
+          (hsPkgs.cardano-sl-util)
           (hsPkgs.cborg)
           (hsPkgs.conduit)
           (hsPkgs.containers)
@@ -51,6 +52,7 @@
           (hsPkgs.tagged)
           (hsPkgs.text)
           (hsPkgs.time)
+          (hsPkgs.time-units)
           (hsPkgs.transformers)
           (hsPkgs.typed-protocols)
           (hsPkgs.unliftio-core)

src/exec/Byron.hs

@@ -13,13 +13,16 @@ module Byron
 
 import Control.Concurrent.STM (STM, atomically, check, readTVar, registerDelay, retry)
 import Control.Exception (IOException, catch, throwIO)
-import Control.Monad (forM_, when)
+import Control.Monad (when)
 import Control.Tracer (Tracer, traceWith)
 import qualified Data.ByteString.Lazy as Lazy (fromStrict)
+import Data.Foldable (foldlM)
 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.Typeable (Typeable)
+import Data.Word (Word64)
 import System.Random (StdGen, getStdGen, randomR)
 
 import qualified Cardano.Binary as Binary
@@ -28,126 +31,159 @@ import qualified Cardano.Chain.Slotting as Cardano
 
 import qualified Pos.Binary.Class as CSL (decodeFull, serialize)
 import qualified Pos.Chain.Block as CSL (Block, BlockHeader (..), GenesisBlock,
-                                         MainBlockHeader, headerHash)
+                                         MainBlockHeader, HeaderHash, headerHash)
 import qualified Pos.Infra.Diffusion.Types as CSL
 
 import Ouroboros.Byron.Proxy.Block (Block, ByronBlockOrEBB (..),
          coerceHashToLegacy, unByronHeaderOrEBB, headerHash)
 import Ouroboros.Byron.Proxy.Main
+import Ouroboros.Consensus.Block (Header)
 import Ouroboros.Consensus.Ledger.Byron (ByronGiven)
+import Ouroboros.Consensus.Protocol.Abstract (SecurityParam (maxRollbacks))
+import Ouroboros.Network.Block (ChainHash (..), Point, pointHash)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import qualified Ouroboros.Network.ChainFragment as CF
 import Ouroboros.Storage.ChainDB.API (ChainDB)
 import qualified Ouroboros.Storage.ChainDB.API as ChainDB
 
 -- | Download the best available chain from Byron peers and write to the
--- database, over and over again.
+-- database, over and over again. It will download the best chain from its
+-- Byron peers regardless of whether it has a better one in the database.
 --
--- No exception handling is done.
+-- The ByronGiven and Typeable constraints are needed in order to use
+-- AF.selectPoints, that's all.
 download
-  :: Tracer IO Text.Builder
+  :: forall cfg void .
+     ( ByronGiven, Typeable cfg )
+  => Tracer IO Text.Builder
   -> CSL.GenesisBlock -- ^ For use as checkpoint when DB is empty. Also will
                       -- be put into an empty DB.
                       -- Sadly, old Byron net API doesn't give any meaning to an
                       -- empty checkpoint set; it'll just fall over.
   -> Cardano.EpochSlots
+  -> SecurityParam
   -> ChainDB IO (Block cfg)
   -> ByronProxy
-  -> (CSL.Block -> Block cfg -> IO ())
-  -> IO x
-download tracer genesisBlock epochSlots db bp k = getStdGen >>= mainLoop Nothing
+  -> IO void
+download tracer genesisBlock epochSlots securityParam db bp = do
+    gen <- getStdGen
+    mTip <- ChainDB.getTipHeader db
+    tipHash <- case mTip of
+      Nothing -> do
+        traceWith tracer "Seeding database with genesis"
+        genesisBlock' :: Block cfg <- recodeBlockOrFail epochSlots throwIO (Left genesisBlock)
+        ChainDB.addBlock db genesisBlock'
+        pure $ CSL.headerHash genesisBlock
+      Just header -> pure $ coerceHashToLegacy (headerHash header)
+    mainLoop gen tipHash
 
   where
 
+  -- The BestTip always gives the longest chain seen so far by Byron. All we
+  -- need to do here is wait until it actually changes, then try to download.
+  -- For checkpoints, we just need to choose some good ones up to k blocks
+  -- back, and everything should work out fine. NB: the checkpoints will only
+  -- be on the main chain.
+  -- getCurrentChain will give exactly what we need.
   waitForNext
-    :: Maybe (BestTip CSL.BlockHeader)
-    -> STM (Either (BestTip CSL.BlockHeader) Atom)
-  waitForNext mBt = do
-    mBt' <- bestTip bp
-    if mBt == mBt'
-    -- If recvAtom retries then the whole STM will retry and we'll check again
-    -- for the best tip to have changed.
-    then fmap Right (recvAtom bp)
-    else case mBt' of
-        Nothing -> retry
-        Just bt -> pure (Left bt)
-
-  mainLoop :: Maybe (BestTip CSL.BlockHeader) -> StdGen -> IO x
-  mainLoop mBt rndGen = do
+    :: CSL.HeaderHash
+    -> STM (BestTip CSL.BlockHeader)
+  waitForNext lastDownloadedHash = do
+    mBt <- bestTip bp
+    case mBt of
+      -- Haven't seen any tips from Byron peers.
+      Nothing -> retry
+      Just bt ->
+          if thisHash == lastDownloadedHash
+          then retry
+          else pure bt
+        where
+          thisHash = CSL.headerHash (btTip bt)
+
+  mainLoop :: StdGen -> CSL.HeaderHash -> IO void
+  mainLoop rndGen tipHash = do
     -- Wait until the best tip has changed from the last one we saw. That can
     -- mean the header changed and/or the list of peers who announced it
     -- changed.
-    next <- atomically $ waitForNext mBt
-    case next of
-      -- TODO we don't get to know from where it was received. Problem? Maybe
-      -- not.
-      Right atom -> do
-        traceWith tracer $ mconcat
-          [ "Got atom: "
-          , Text.fromString (show atom)
-          ]
-        mainLoop mBt rndGen
-      Left bt -> do
-        mTip <- ChainDB.getTipHeader db
-        tipHash <- case mTip of
-          -- If the DB is empty, we use the genesis hash as our tip, but also
-          -- we need to put the genesis block into the database, because the
-          -- Byron peer _will not serve it to us_!
-          Nothing -> do
-            traceWith tracer "Seeding database with genesis"
-            genesisBlock' :: Block cfg <- recodeBlockOrFail epochSlots throwIO (Left genesisBlock)
-            ChainDB.addBlock db genesisBlock'
-            pure $ CSL.headerHash genesisBlock
-          Just header -> pure $ coerceHashToLegacy (headerHash header)
-        -- Pick a peer from the list of announcers at random and download
-        -- the chain.
-        let (peer, rndGen') = pickRandom rndGen (btPeers bt)
-            remoteTipHash = CSL.headerHash (btTip bt)
-        traceWith tracer $ mconcat
-          [ "Attempting to download chain with hash "
-          , Text.fromString (show remoteTipHash)
-          , " from "
-          , Text.fromString (show peer)
-          ]
-        -- Try to download the chain, but do not die in case of IOExceptions.
-        _ <- downloadChain
-               bp
-               peer
-               remoteTipHash
-               [tipHash]
-               streamer
-          `catch`
-          exceptionHandler
-        mainLoop (Just bt) rndGen'
-
-  -- If it ends at an EBB, the EBB will _not_ be written. The tip will be the
-  -- parent of the EBB.
-  -- This should be OK.
-  streamer :: CSL.StreamBlocks CSL.Block IO ()
-  streamer = CSL.StreamBlocks
+    bt <- atomically $ waitForNext tipHash
+    -- Pick a peer from the list of announcers at random and download
+    -- the chain.
+    let (peer, rndGen') = pickRandom rndGen (btPeers bt)
+    chain <- atomically $ ChainDB.getCurrentChain db
+    traceWith tracer $ mconcat
+      [ "Attempting to download chain with hash "
+      , Text.fromString (show tipHash)
+      , " from "
+      , Text.fromString (show peer)
+      ]
+    -- Try to download the chain, but do not die in case of IOExceptions.
+    -- The hash of the last downloaded block is returned, so that on the next
+    -- recursive call, that chain won't be downloaded again. If there's an
+    -- exception, or if batch downloaded was used, this hash may not be the
+    -- hash of the tip of the chain that was to be downloaded.
+    tipHash' <- downloadChain
+        bp
+        peer
+        (CSL.headerHash (btTip bt))
+        (checkpoints chain)
+        (streamer tipHash)
+      `catch`
+        exceptionHandler tipHash
+    mainLoop rndGen' tipHash'
+
+  checkpoints
+    :: AF.AnchoredFragment (Header (Block cfg))
+    -> [CSL.HeaderHash]
+  checkpoints = mapMaybe pointToHash . AF.selectPoints (fmap fromIntegral offsets)
+
+  pointToHash :: Point (Header (Block cfg)) -> Maybe CSL.HeaderHash
+  pointToHash pnt = case pointHash pnt of
+    GenesisHash    -> Nothing
+    BlockHash 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
         -- List comes in newest-to-oldest order.
         let orderedBlocks = NE.toList (NE.reverse blocks)
         -- The blocks are legacy CSL blocks. To put them into the DB, we must
         -- convert them to new cardano-ledger blocks. That's done by
         -- encoding and decoding.
-        forM_ orderedBlocks $ \blk -> do
-          blk' <- recodeBlockOrFail epochSlots throwIO blk
-          ChainDB.addBlock db blk'
-          k blk blk'
-        pure streamer
-    , CSL.streamBlocksDone = pure ()
+        tipHash' <- foldlM commitBlock tipHash orderedBlocks
+        pure (streamer tipHash')
+    , CSL.streamBlocksDone = pure tipHash
     }
 
+  commitBlock :: CSL.HeaderHash -> CSL.Block -> IO CSL.HeaderHash
+  commitBlock _ blk = do
+    blk' <- recodeBlockOrFail epochSlots throwIO blk
+    ChainDB.addBlock db blk'
+    pure $ CSL.headerHash blk
+
   -- No need to trace it; cardano-sl libraries will do that.
-  exceptionHandler :: IOException -> IO (Maybe ())
-  exceptionHandler _ = pure Nothing
+  exceptionHandler :: CSL.HeaderHash -> IOException -> IO CSL.HeaderHash
+  exceptionHandler h _ = pure h
 
   pickRandom :: StdGen -> NonEmpty t -> (t, StdGen)
   pickRandom rndGen ne =
     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

@@ -27,7 +27,8 @@ import qualified Ouroboros.Consensus.Ledger.Byron          as Byron
 import           Ouroboros.Consensus.Ledger.Byron.Config   (ByronConfig)
 import           Ouroboros.Consensus.Ledger.Extended       (ExtLedgerState)
 import           Ouroboros.Consensus.Protocol              (NodeConfig)
-import           Ouroboros.Consensus.Protocol.Abstract     (SecurityParam (..))
+import           Ouroboros.Consensus.Protocol.Abstract     (SecurityParam (..),
+                                                            protocolSecurityParam)
 import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
 import qualified Ouroboros.Consensus.Util.ResourceRegistry as ResourceRegistry
 import           Ouroboros.Storage.ChainDB.API             (ChainDB)
@@ -60,12 +61,11 @@ withDB
   -> Tracer IO (ChainDB.TraceEvent (Block ByronConfig))
   -> Tracer IO Sqlite.TraceEvent
   -> ResourceRegistry IO
-  -> SecurityParam
   -> NodeConfig (BlockProtocol (Block ByronConfig))
   -> ExtLedgerState (Block ByronConfig)
   -> (Index IO (Header (Block ByronConfig)) -> ChainDB IO (Block ByronConfig) -> IO t)
   -> IO t
-withDB dbOptions dbTracer indexTracer rr securityParam nodeConfig extLedgerState k = do
+withDB dbOptions dbTracer indexTracer rr nodeConfig extLedgerState k = do
   -- The ChainDB/Storage layer will not create a directory for us, we have
   -- to ensure it exists.
   System.Directory.createDirectoryIfMissing True (dbFilePath dbOptions)
@@ -116,7 +116,7 @@ withDB dbOptions dbTracer indexTracer rr securityParam nodeConfig extLedgerState
 
         , cdbValidation = ValidateMostRecentEpoch
         , cdbBlocksPerFile = 21600 -- ?
-        , cdbMemPolicy = defaultMemPolicy securityParam
+        , cdbMemPolicy = defaultMemPolicy (protocolSecurityParam nodeConfig)
         , cdbDiskPolicy = ledgerDiskPolicy
 
         , cdbNodeConfig = nodeConfig