CBR-499: Extend LastBksSlots data type and storage for OBFT

chain/cardano-sl-chain.cabal

@@ -155,8 +155,10 @@ library
                      , aeson
                      , aeson-options
                      , array
+                     , base16-bytestring
                      , bytestring
                      , Cabal
+                     , cardano-crypto
                      , canonical-json
                      , cardano-sl-binary
                      , cardano-sl-core

chain/src/Pos/Chain/Block/Error.hs

@@ -17,7 +17,7 @@ import           Formatting.Buildable (Buildable (..))
 import           GHC.Generics (Generic)
 
 import           Pos.Chain.Block.Header (HeaderHash)
-import           Pos.Crypto (shortHashF)
+import           Pos.Crypto (mediumHashF)
 
 
 -- | This function can be used to create a message when tip mismatch
@@ -27,7 +27,7 @@ tipMismatchMsg :: Text -> HeaderHash -> HeaderHash -> Builder
 tipMismatchMsg action storedTip attemptedTip =
     bprint
         ("Can't "%stext%" block because of tip mismatch (stored is "
-         %shortHashF%", attempted is "%shortHashF%")")
+         %mediumHashF%", attempted is "%mediumHashF%")")
         action storedTip attemptedTip
 
 data RollbackException = RollbackTipMismatch HeaderHash HeaderHash

chain/src/Pos/Chain/Block/Slog/Types.hs

@@ -2,6 +2,7 @@
 
 module Pos.Chain.Block.Slog.Types
        ( LastBlkSlots
+       , LastSlotInfo (..)
        , noLastBlkSlots
 
        , SlogGState (..)
@@ -16,21 +17,43 @@ module Pos.Chain.Block.Slog.Types
 
 import           Universum
 
+import qualified Cardano.Crypto.Wallet as CC
 import           Control.Lens (makeClassy)
-import           Formatting (Format, bprint, later)
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString.Char8 as BS
+import           Formatting (Format, bprint, int, later, string, (%))
+import qualified Formatting.Buildable as Buildable
+
 import           System.Metrics.Label (Label)
 
 import           Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi)
 import           Pos.Core (ChainDifficulty, EpochIndex, FlatSlotId,
                      LocalSlotIndex, SlotCount, slotIdF, unflattenSlotId)
 import           Pos.Core.Chrono (OldestFirst (..))
 import           Pos.Core.Reporting (MetricMonitorState)
+import           Pos.Crypto (PublicKey (..))
+
+
+data LastSlotInfo = LastSlotInfo
+    { lsiFlatSlotId       :: !FlatSlotId
+    -- ^ The flattened SlotId of this block.
+    , lsiLeaderPubkeyHash :: !PublicKey
+    -- ^ The hash of the public key of the slot leader for this slot.
+    } deriving (Eq, Show, Generic)
+
+instance Buildable LastSlotInfo where
+    build (LastSlotInfo i (PublicKey pk)) =
+        bprint ( "LastSlotInfo "% int %" "% string)
+            i (take 16 . BS.unpack . B16.encode $ CC.xpubPublicKey pk)
 
 -- | This type contains 'FlatSlotId's of the blocks whose depth is
 -- less than 'blkSecurityParam'. 'FlatSlotId' is chosen in favor of
 -- 'SlotId', because the main use case is chain quality calculation,
 -- for which flat slot is more convenient.
-type LastBlkSlots = OldestFirst [] FlatSlotId
+-- Version 1 of this data type was:
+--      type LastBlkSlots = OldestFirst [] FlatSlotId
+type LastBlkSlots = OldestFirst [] LastSlotInfo
+
 
 noLastBlkSlots :: LastBlkSlots
 noLastBlkSlots = OldestFirst []
@@ -102,3 +125,10 @@ deriveSimpleBi ''SlogUndo [
     Cons 'SlogUndo [
         Field [| getSlogUndo  :: Maybe FlatSlotId |]
     ]]
+
+deriveSimpleBi ''LastSlotInfo [
+    Cons 'LastSlotInfo [
+        Field [| lsiFlatSlotId :: FlatSlotId |],
+        Field [| lsiLeaderPubkeyHash :: PublicKey |]
+        ]
+    ]

core/src/Pos/Core/Slotting/SlotCount.hs

@@ -10,6 +10,8 @@ import           System.Random (Random (..))
 
 import           Pos.Binary.Class (Bi (..))
 
+-- | This type actually contains the number of slots per epoch, but the people
+-- who wrote this code hate us!
 newtype SlotCount = SlotCount {getSlotCount :: Word64}
     deriving (Eq, Ord, Num, Real, Integral, Enum, Read, Show,
               Buildable, Generic, Typeable, NFData, Hashable, Random)

db/src/Pos/DB/Block/GState/BlockExtra.hs

@@ -8,6 +8,9 @@ module Pos.DB.Block.GState.BlockExtra
        ( resolveForwardLink
        , isBlockInMainChain
        , getLastSlots
+       , putLastSlots
+       , rollbackLastSlots
+       , upgradeLastSlotsVersion
        , getFirstGenesisBlockHash
        , BlockExtraOp (..)
        , buildBlockExtraOp
@@ -22,22 +25,28 @@ module Pos.DB.Block.GState.BlockExtra
 import           Universum hiding (init)
 
 import           Data.Conduit (ConduitT, yield)
+
 import qualified Database.RocksDB as Rocks
 import           Formatting (Format, bprint, build, later, (%))
 import           Serokell.Util.Text (listJson)
 
 import           Pos.Binary.Class (serialize')
-import           Pos.Chain.Block (Block, BlockHeader, HasHeaderHash, HeaderHash,
-                     LastBlkSlots, headerHash, noLastBlkSlots)
-import           Pos.Chain.Genesis (GenesisHash (..))
-import           Pos.Core (FlatSlotId, SlotCount, slotIdF, unflattenSlotId)
+import           Pos.Chain.Block (Block, BlockHeader (..), HasHeaderHash,
+                     HeaderHash, LastBlkSlots, LastSlotInfo (..), headerHash,
+                     mainHeaderLeaderKey, noLastBlkSlots, prevBlockL)
+import           Pos.Chain.Genesis (GenesisHash (..), configBlkSecurityParam,
+                     configEpochSlots)
+import qualified Pos.Chain.Genesis as Genesis
+import           Pos.Core (FlatSlotId, SlotCount, flattenEpochOrSlot,
+                     getEpochOrSlot, slotIdF, unflattenSlotId)
 import           Pos.Core.Chrono (OldestFirst (..))
-import           Pos.Crypto (shortHashF)
+import           Pos.Crypto (PublicKey, shortHashF)
 import           Pos.DB (DBError (..), MonadDB, MonadDBRead (..),
-                     RocksBatchOp (..), getHeader)
+                     RocksBatchOp (..), getHeader, getTipHeader, gsDelete)
 import           Pos.DB.Class (MonadBlockDBRead, SerializedBlock, getBlock)
 import           Pos.DB.GState.Common (gsGetBi, gsPutBi)
 import           Pos.Util.Util (maybeThrow)
+import           Pos.Util.Wlog (CanLog)
 
 ----------------------------------------------------------------------------
 -- Getters
@@ -60,8 +69,69 @@ isBlockInMainChain h =
 -- less than 'blkSecurityParam'.
 getLastSlots :: forall m . MonadDBRead m => m LastBlkSlots
 getLastSlots =
-    maybeThrow (DBMalformed "Last slots not found in the global state DB") =<<
-    gsGetBi lastSlotsKey
+    gsGetBi lastSlotsKey2 >>=
+        maybeThrow (DBMalformed "Last slots v2 not found in the global state DB")
+
+putLastSlots :: forall m . MonadDB m => LastBlkSlots -> m ()
+putLastSlots =
+    gsPutBi lastSlotsKey2
+
+-- | Roll back slots.
+-- This assumes that the tip header (retrieved via `getTipHeader` has already
+-- been rolled back.
+rollbackLastSlots :: forall m . (CanLog m, MonadIO m, MonadDB m) => Genesis.Config -> m ()
+rollbackLastSlots genesisConfig = do
+    -- Simple is better. Find the 'FlatSlotId' of the tip header and then generate
+    -- the required 'LastBlkSlots' data from that.
+    gsPutBi lastSlotsKey2 =<< getLastSlotInfo genesisConfig
+
+
+-- | This function acts as a one time conversion from version 1 to version 2
+-- of the `LastBlkSlots` data type.
+upgradeLastSlotsVersion :: forall m . (MonadDB m, MonadIO m) => Genesis.Config -> m ()
+upgradeLastSlotsVersion genesisConfig =
+    gsGetBi oldLastSlotsKey >>= \case
+        Nothing -> pure () -- Assume it has already been converted.
+        Just (_ :: OldestFirst [] FlatSlotId) -> do
+            gsPutBi lastSlotsKey2 =<< getLastSlotInfo genesisConfig
+            gsDelete oldLastSlotsKey -- Delete the old key
+  where
+    -- This is the DB key for version 1 of the `LastBlksSlots` data type that only
+    -- contains a list of `FlatSlotId`s
+    oldLastSlotsKey :: ByteString
+    oldLastSlotsKey = "e/ls/"
+
+
+-- Get the 'LastSlotInfo' data for the last 'k' (security paramenter) starting
+-- at the current blockchain tip.
+getLastSlotInfo :: (MonadDB m, MonadIO m) => Genesis.Config -> m LastBlkSlots
+getLastSlotInfo genesisConfig = do
+    th <- getTipHeader
+    let thfsid = flattenEpochOrSlot (configEpochSlots genesisConfig) $ getEpochOrSlot th
+        lastfsid =
+            if thfsid <= fromIntegral (configBlkSecurityParam genesisConfig - 1)
+                then 0
+                else thfsid - fromIntegral (configBlkSecurityParam genesisConfig - 1)
+    OldestFirst <$> convert th lastfsid []
+  where
+    convert :: (MonadDB m, MonadIO m) => BlockHeader -> FlatSlotId -> [LastSlotInfo] -> m [LastSlotInfo]
+    convert bh lastFsid !acc = do
+        let bhFsid = flattenEpochOrSlot (configEpochSlots genesisConfig) $ getEpochOrSlot bh
+        if bhFsid < lastFsid
+            then pure acc
+            else do
+                let ys = case leaderKey bh of
+                            Nothing -> acc
+                            Just lk -> LastSlotInfo bhFsid lk : acc
+                mnbh <- getHeader $ view prevBlockL bh
+                case mnbh of
+                    Nothing  -> pure acc
+                    Just nbh -> convert nbh lastFsid ys
+
+    leaderKey :: BlockHeader -> Maybe PublicKey
+    leaderKey = \case
+        BlockHeaderGenesis _ -> Nothing
+        BlockHeaderMain bhm -> Just $ view mainHeaderLeaderKey bhm
 
 -- | Retrieves first genesis block hash.
 getFirstGenesisBlockHash :: MonadDBRead m => GenesisHash -> m HeaderHash
@@ -82,7 +152,7 @@ data BlockExtraOp
     | SetInMainChain Bool
                      HeaderHash
       -- ^ Enables or disables "in main chain" status of the block
-    | SetLastSlots (OldestFirst [] FlatSlotId)
+    | SetLastSlots LastBlkSlots
       -- ^ Updates list of slots for last blocks.
     deriving (Show)
 
@@ -97,7 +167,7 @@ buildBlockExtraOp epochSlots = later build'
         bprint ("SetInMainChain for "%shortHashF%": "%build) h flag
     build' (SetLastSlots slots) =
         bprint ("SetLastSlots: "%listJson)
-        (map (bprint slotIdF . unflattenSlotId epochSlots) slots)
+        (map (bprint slotIdF . unflattenSlotId epochSlots . lsiFlatSlotId) slots)
 
 instance RocksBatchOp BlockExtraOp where
     toBatchOp (AddForwardLink from to) =
@@ -109,7 +179,7 @@ instance RocksBatchOp BlockExtraOp where
     toBatchOp (SetInMainChain True h) =
         [Rocks.Put (mainChainKey h) (serialize' ()) ]
     toBatchOp (SetLastSlots slots) =
-        [Rocks.Put lastSlotsKey (serialize' slots)]
+        [Rocks.Put lastSlotsKey2 (serialize' slots)]
 
 ----------------------------------------------------------------------------
 -- Loops on forward links
@@ -211,7 +281,7 @@ initGStateBlockExtra :: MonadDB m => GenesisHash -> HeaderHash -> m ()
 initGStateBlockExtra genesisHash firstGenesisHash = do
     gsPutBi (mainChainKey firstGenesisHash) ()
     gsPutBi (forwardLinkKey $ getGenesisHash genesisHash) firstGenesisHash
-    gsPutBi lastSlotsKey noLastBlkSlots
+    gsPutBi lastSlotsKey2 noLastBlkSlots
 
 ----------------------------------------------------------------------------
 -- Keys
@@ -223,5 +293,6 @@ forwardLinkKey h = "e/fl/" <> serialize' h
 mainChainKey :: HeaderHash -> ByteString
 mainChainKey h = "e/mc/" <> serialize' h
 
-lastSlotsKey :: ByteString
-lastSlotsKey = "e/ls/"
+-- This is the DB key for version 2 of the `LastBlksSlots`.
+lastSlotsKey2 :: ByteString
+lastSlotsKey2 = "e/ls2/"

db/src/Pos/DB/Block/Logic/Internal.hs

@@ -54,6 +54,7 @@ import           Pos.Core.Slotting (epochOrSlotToEpochIndex, getEpochOrSlot)
 import           Pos.DB (MonadDB, MonadDBRead, MonadGState, SomeBatchOp (..))
 import           Pos.DB.Block.BListener (MonadBListener)
 import           Pos.DB.Block.GState.SanityCheck (sanityCheckDB)
+import           Pos.DB.Block.Slog.Context (slogRollbackLastSlots)
 import           Pos.DB.Block.Slog.Logic (BypassSecurityCheck (..),
                      MonadSlogApply, MonadSlogBase, ShouldCallBListener,
                      slogApplyBlocks, slogRollbackBlocks)
@@ -224,8 +225,7 @@ rollbackBlocksUnsafe
     -> NewestFirst NE Blund
     -> m ()
 rollbackBlocksUnsafe genesisConfig bsc scb toRollback = do
-    slogRoll <- slogRollbackBlocks (makeNetworkMagic $ configProtocolMagic genesisConfig)
-                                   (configProtocolConstants genesisConfig)
+    slogRoll <- slogRollbackBlocks genesisConfig
                                    bsc
                                    scb
                                    toRollback
@@ -244,6 +244,7 @@ rollbackBlocksUnsafe genesisConfig bsc scb toRollback = do
         , sscBatch
         , slogRoll
         ]
+    slogRollbackLastSlots genesisConfig
     -- After blocks are rolled back it makes sense to recreate the
     -- delegation mempool.
     -- We don't normalize other mempools, because they are normalized

db/src/Pos/DB/Block/Logic/Util.hs

@@ -24,8 +24,8 @@ import qualified Data.List.NonEmpty as NE
 import           Formatting (int, sformat, (%))
 
 import           Pos.Chain.Block (BlockHeader, HasBlockConfiguration,
-                     HasSlogGState, HeaderHash, fixedTimeCQ, headerHash,
-                     prevBlockL)
+                     HasSlogGState, HeaderHash, LastSlotInfo (..), fixedTimeCQ,
+                     headerHash, prevBlockL)
 import           Pos.Core (BlockCount, FlatSlotId, SlotCount, Timestamp (..),
                      difficultyL, flattenSlotId)
 import           Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..))
@@ -35,7 +35,7 @@ import           Pos.Core.Slotting (MonadSlots (..), getCurrentSlotFlat,
 import           Pos.DB.Block.GState.BlockExtra (isBlockInMainChain)
 import           Pos.DB.Block.Slog.Context (slogGetLastSlots)
 import qualified Pos.DB.BlockIndex as DB
-import           Pos.DB.Class (MonadBlockDBRead)
+import           Pos.DB.Class (MonadBlockDBRead, MonadDBRead)
 import           Pos.Util (_neHead)
 import           Pos.Util.Wlog (WithLogger)
 
@@ -100,9 +100,9 @@ calcChainQuality blockCount deepSlot newSlot
 -- 'blkSecurityParam' blocks.
 calcChainQualityM
     :: ( MonadReader ctx m
+       , MonadDBRead m
        , HasSlogGState ctx
        , MonadIO m
-       , MonadThrow m
        , WithLogger m
        , Fractional res
        )
@@ -123,7 +123,7 @@ calcChainQualityM k newSlot = do
                 return
                     (calcChainQuality
                          (fromIntegral len)
-                         (NE.head slotsNE)
+                         (lsiFlatSlotId $ NE.head slotsNE)
                          newSlot)
 
 -- | Calculate overall chain quality, i. e. number of main blocks
@@ -172,7 +172,7 @@ calcChainQualityFixedTime epochSlots = do
     (,) <$> slotFromTimestamp epochSlots olderTime <*> getCurrentSlotFlat epochSlots >>= \case
         (Just (flattenSlotId epochSlots -> olderSlotId), Just currentSlotId) ->
             calcChainQualityFixedTimeDo olderSlotId currentSlotId <$>
-            slogGetLastSlots
+                (lsiFlatSlotId <<$>> slogGetLastSlots)
         _ -> return Nothing
   where
     -- 'lastSlots' contains slots of last 'k' blocks.

db/src/Pos/DB/Block/Slog/Context.hs

@@ -8,6 +8,7 @@ module Pos.DB.Block.Slog.Context
        , cloneSlogGState
        , slogGetLastSlots
        , slogPutLastSlots
+       , slogRollbackLastSlots
        ) where
 
 import           Universum
@@ -18,11 +19,16 @@ import qualified System.Metrics as Ekg
 import           Pos.Chain.Block (HasBlockConfiguration, HasSlogGState (..),
                      LastBlkSlots, SlogContext (..), SlogGState (..),
                      fixedTimeCQSec, sgsLastBlkSlots)
+import           Pos.Chain.Genesis as Genesis (Config (..))
 import           Pos.Core (BlockCount)
 import           Pos.Core.Metrics.Constants (withCardanoNamespace)
 import           Pos.Core.Reporting (MetricMonitorState, mkMetricMonitorState)
-import           Pos.DB.Block.GState.BlockExtra (getLastSlots)
-import           Pos.DB.Class (MonadDBRead)
+import           Pos.DB.Block.GState.BlockExtra (getLastSlots, putLastSlots,
+                     rollbackLastSlots)
+import           Pos.DB.Class (MonadDB, MonadDBRead)
+
+import           Pos.Util.Wlog (CanLog)
+
 
 -- | Make new 'SlogGState' using data from DB.
 mkSlogGState :: (MonadIO m, MonadDBRead m) => m SlogGState
@@ -70,12 +76,27 @@ cloneSlogGState SlogGState {..} =
 -- | Read 'LastBlkSlots' from in-memory state.
 slogGetLastSlots ::
        (MonadReader ctx m, HasSlogGState ctx, MonadIO m) => m LastBlkSlots
-slogGetLastSlots = view (slogGState . sgsLastBlkSlots) >>= readIORef
+slogGetLastSlots =
+    -- 'LastBlkSlots' is stored in two places, the DB and an 'IORef' so just
+    -- grab the copy in the 'IORef'.
+    readIORef =<< view (slogGState . sgsLastBlkSlots)
 
 -- | Update 'LastBlkSlots' in 'SlogContext'.
 slogPutLastSlots ::
-       (MonadReader ctx m, HasSlogGState ctx, MonadIO m)
+       (MonadReader ctx m, MonadDB m, HasSlogGState ctx, MonadIO m)
     => LastBlkSlots
     -> m ()
-slogPutLastSlots slots =
+slogPutLastSlots slots = do
+    -- When we set 'LastBlkSlots' we set it in both the DB and the 'IORef'.
+    view (slogGState . sgsLastBlkSlots) >>= flip writeIORef slots
+    putLastSlots slots
+
+-- | Roll back the specified count of 'LastBlkSlots'.
+slogRollbackLastSlots
+    :: (CanLog m, MonadReader ctx m, MonadDB m, HasSlogGState ctx, MonadIO m)
+    => Genesis.Config -> m ()
+slogRollbackLastSlots genesisConfig = do
+    -- Roll back in the DB, then read the DB and set the 'IORef'.
+    rollbackLastSlots genesisConfig
+    slots <- getLastSlots
     view (slogGState . sgsLastBlkSlots) >>= flip writeIORef slots