Byron chain download uses better checkpoints

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