wip: BlockHistory changes

1. BlockHistoryMigration starts rewinding to the final block in
   BlockHistory and setting the consensus state to that block, as part
   of cleanup. (needs tests)
2. Many utilities moved from ChainwebPactDb to Backend.Utils. (these are
   not specific to PactDb though they are related to storage)
3. Stop maintaining a "latest" in ConsensusState table. This is only the
   latest row in BlockHistory table now.

Change-Id: Id00000001c55cdeb49e0280cadaf17bb040a381f

Author: edmundnoble

src/Chainweb/Pact/Backend/ChainwebPactDb.hs

@@ -761,58 +761,6 @@ createVersionedTable tablename db = do
     indexcreationstmt =
         "CREATE INDEX IF NOT EXISTS " <> tbl ixName <> " ON " <> tbl tablename <> "(txid DESC);"
 
-setConsensusState :: SQ3.Database -> ConsensusState -> ExceptT LocatedSQ3Error IO ()
-setConsensusState db cs = do
-    withSavepoint db SetConsensusSavePoint $ do
-        exec' db
-            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
-            \(?, ?, ?, ?);"
-            (toRow "final" $ _consensusStateFinal cs)
-        exec' db
-            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
-            \(?, ?, ?, ?);"
-            (toRow "safe" $ _consensusStateSafe cs)
-        exec' db
-            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
-            \(?, ?, ?, ?);"
-            (toRow "latest" $ _consensusStateLatest cs)
-    where
-    toRow safety SyncState {..} =
-        [ SInt $ fromIntegral @BlockHeight @Int64 _syncStateHeight
-        , SBlob $ runPutS (encodeBlockHash _syncStateBlockHash)
-        , SBlob $ runPutS (encodeBlockPayloadHash _syncStateBlockPayloadHash)
-        , SText safety
-        ]
-
-getConsensusState :: SQ3.Database -> ExceptT LocatedSQ3Error IO (Maybe ConsensusState)
-getConsensusState db = do
-    maybeState <- qry db "SELECT blockheight, hash, payloadhash, safety FROM ConsensusState ORDER BY safety ASC;"
-        [] [RInt, RBlob, RBlob, RText] >>= \case
-            [final, latest, safe] -> return $ Just ConsensusState
-                { _consensusStateFinal = readRow "final" final
-                , _consensusStateLatest = readRow "latest" latest
-                , _consensusStateSafe = readRow "safe" safe
-                }
-            [] -> return Nothing
-            inv -> error $ "invalid contents of the ConsensusState table: " <> sshow inv
-    case maybeState of
-        Nothing -> do
-            getLatestBlock db >>= \case
-                Nothing -> return Nothing
-                Just latest ->
-                    return $ Just $ ConsensusState latest latest latest
-        Just s -> return (Just s)
-    where
-    readRow expectedType [SInt height, SBlob hash, SBlob payloadHash, SText type']
-        | expectedType == type' = SyncState
-            { _syncStateHeight = fromIntegral @Int64 @BlockHeight height
-            , _syncStateBlockHash = either error id $ runGetEitherS decodeBlockHash hash
-            , _syncStateBlockPayloadHash = either error id $ runGetEitherS decodeBlockPayloadHash payloadHash
-            }
-        | otherwise = error $ "wrong type; expected " <> sshow expectedType <> " but got " <> sshow type'
-    readRow expectedType invalidRow
-        = error $ "invalid row: expected " <> sshow expectedType <> " but got row " <> sshow invalidRow
-
 -- | Create all tables that exist pre-genesis
 -- TODO: migrate this logic to the checkpointer itself?
 initSchema :: SQLiteEnv -> IO ()
@@ -888,81 +836,3 @@ getSerialiser = do
     cid <- view blockHandlerChainId
     blockHeight <- view blockHandlerBlockHeight
     return $ pact5Serialiser cid blockHeight
-
-getPayloadsAfter :: HasCallStack => SQLiteEnv -> Parent BlockHeight -> ExceptT LocatedSQ3Error IO [Ranked BlockPayloadHash]
-getPayloadsAfter db parentHeight = do
-    qry db "SELECT blockheight, payloadhash FROM BlockHistory2 WHERE blockheight > ?"
-        [SInt (fromIntegral @BlockHeight @Int64 (unwrapParent parentHeight))]
-        [RInt, RBlob] >>= traverse
-        \case
-            [SInt bh, SBlob bhash] ->
-                return $! Ranked (fromIntegral @Int64 @BlockHeight bh) $ either error id $ runGetEitherS decodeBlockPayloadHash bhash
-            _ -> error "incorrect column type"
-
--- | Get the checkpointer's idea of the earliest block. The block height
--- is the height of the block of the block hash.
-getEarliestBlock :: HasCallStack => SQLiteEnv -> ExceptT LocatedSQ3Error IO (Maybe RankedBlockHash)
-getEarliestBlock db = do
-    r <- qry db qtext [] [RInt, RBlob] >>= mapM go
-    case r of
-        [] -> return Nothing
-        (!o:_) -> return (Just o)
-    where
-    qtext = "SELECT blockheight, hash FROM BlockHistory2 ORDER BY blockheight ASC LIMIT 1"
-
-    go [SInt hgt, SBlob blob] =
-        let hash = either error id $ runGetEitherS decodeBlockHash blob
-        in return (RankedBlockHash (fromIntegral hgt) hash)
-    go _ = fail "Chainweb.Pact.Backend.RelationalCheckpointer.doGetEarliest: impossible. This is a bug in chainweb-node."
-
--- | Get the checkpointer's idea of the latest block.
-getLatestBlock :: HasCallStack => SQLiteEnv -> ExceptT LocatedSQ3Error IO (Maybe SyncState)
-getLatestBlock db = do
-    r <- qry db qtext [] [RInt, RBlob, RBlob] >>= mapM go
-    case r of
-        [] -> return Nothing
-        (!o:_) -> return (Just o)
-    where
-    qtext = "SELECT blockheight, hash, payloadhash FROM BlockHistory2 ORDER BY blockheight DESC LIMIT 1"
-
-    go [SInt hgt, SBlob blob, SBlob pBlob] =
-        let hash = either error id $ runGetEitherS decodeBlockHash blob
-        in let pHash = either error id $ runGetEitherS decodeBlockPayloadHash pBlob
-        in return $ SyncState
-            { _syncStateBlockHash = hash
-            , _syncStateBlockPayloadHash = pHash
-            , _syncStateHeight = int hgt
-            }
-    go r = fail $
-        "Chainweb.Pact.Backend.ChainwebPactDb.getLatestBlock: impossible. This is a bug in chainweb-node. Details: "
-        <> sshow r
-
-lookupBlockWithHeight :: HasCallStack => SQ3.Database -> BlockHeight -> ExceptT LocatedSQ3Error IO (Maybe (Ranked BlockHash))
-lookupBlockWithHeight db bheight = do
-    qry db qtext [SInt $ fromIntegral bheight] [RBlob] >>= \case
-        [[SBlob hash]] -> return $! Just $!
-            Ranked bheight (either error id $ runGetEitherS decodeBlockHash hash)
-        [] -> return Nothing
-        res -> error $ "Invalid result, " <> sshow res
-    where
-    qtext = "SELECT hash FROM BlockHistory2 WHERE blockheight = ?;"
-
-lookupBlockHash :: HasCallStack => SQ3.Database -> BlockHash -> ExceptT LocatedSQ3Error IO (Maybe BlockHeight)
-lookupBlockHash db hash = do
-    qry db qtext [SBlob (runPutS (encodeBlockHash hash))] [RInt] >>= \case
-        [[SInt n]] -> return $! Just $! int n
-        [] -> return $ Nothing
-        res -> error $ "Invalid result, " <> sshow res
-    where
-   qtext = "SELECT blockheight FROM BlockHistory2 WHERE hash = ?;"
-
-lookupRankedBlockHash :: HasCallStack => SQ3.Database -> RankedBlockHash -> IO Bool
-lookupRankedBlockHash db rankedBHash = throwOnDbError $ do
-    qry db qtext
-        [ SInt $ fromIntegral (_rankedBlockHashHeight rankedBHash)
-        , SBlob $ runPutS $ encodeBlockHash $ _rankedBlockHashHash rankedBHash
-        ] [RInt] >>= \case
-        [[SInt n]] -> return $! n == 1
-        res -> error $ "Invalid result, " <> sshow res
-    where
-    qtext = "SELECT COUNT(*) FROM BlockHistory2 WHERE blockheight = ? AND hash = ?;"

src/Chainweb/Pact/Backend/Utils.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE BlockArguments #-}
 
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -37,6 +38,14 @@ module Chainweb.Pact.Backend.Utils
   , rewindDbToBlock
   , rewindDbToGenesis
   , getEndTxId
+  , setConsensusState
+  , getConsensusState
+  , getPayloadsAfter
+  , getLatestBlock
+  , getEarliestBlock
+  , lookupBlockWithHeight
+  , lookupBlockHash
+  , lookupRankedBlockHash
     -- * Savepoints
   , withSavepoint
   , SavepointName(..)
@@ -78,6 +87,7 @@ import Control.Monad.Trans.Resource (ResourceT, allocate)
 
 import Data.Bits
 import Data.Foldable
+import Data.Maybe
 import Data.String
 import Data.Pool qualified as Pool
 import Data.Text qualified as T
@@ -100,6 +110,7 @@ import Pact.Types.Util (AsString(..))
 
 import Chainweb.Logger
 import Chainweb.Pact.Backend.SQLite.DirectV2
+import Chainweb.PayloadProvider
 
 import Chainweb.Version
 import Chainweb.Utils
@@ -509,6 +520,128 @@ rewindDbToBlock db bh endingTxId = throwOnDbError $ do
         exec' db "DELETE FROM TransactionIndex WHERE blockheight > ?;"
               [ SInt (fromIntegral bh) ]
 
+-- | Set the consensus state. Note that the "latest" parameter is ignored; the
+-- latest block is always the highest block in the BlockHistory table.
+setConsensusState :: SQ3.Database -> ConsensusState -> ExceptT LocatedSQ3Error IO ()
+setConsensusState db cs = do
+    withSavepoint db SetConsensusSavePoint $ do
+        exec' db
+            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
+            \(?, ?, ?, ?);"
+            (toRow "final" $ _consensusStateFinal cs)
+        exec' db
+            "INSERT INTO ConsensusState (blockheight, hash, payloadhash, safety) VALUES \
+            \(?, ?, ?, ?);"
+            (toRow "safe" $ _consensusStateSafe cs)
+    where
+    toRow safety SyncState {..} =
+        [ SInt $ fromIntegral @BlockHeight @Int64 _syncStateHeight
+        , SBlob $ runPutS (encodeBlockHash _syncStateBlockHash)
+        , SBlob $ runPutS (encodeBlockPayloadHash _syncStateBlockPayloadHash)
+        , SText safety
+        ]
+
+-- | Retrieve the latest "consensus state" including latest, safe, and final blocks.
+getConsensusState :: SQ3.Database -> ExceptT LocatedSQ3Error IO ConsensusState
+getConsensusState db = do
+    latestBlock <- fromMaybe (error "before genesis") <$> getLatestBlock db
+    qry db "SELECT blockheight, hash, payloadhash, safety FROM ConsensusState ORDER BY safety ASC;"
+        [] [RInt, RBlob, RBlob, RText] >>= \case
+            [final, safe] -> return $ ConsensusState
+                { _consensusStateFinal = readRow "final" final
+                , _consensusStateSafe = readRow "safe" safe
+                , _consensusStateLatest = latestBlock
+                }
+            inv -> error $ "invalid contents of the ConsensusState table: " <> sshow inv
+    where
+    readRow expectedType [SInt height, SBlob hash, SBlob payloadHash, SText type']
+        | expectedType == type' = SyncState
+            { _syncStateHeight = fromIntegral @Int64 @BlockHeight height
+            , _syncStateBlockHash = either error id $ runGetEitherS decodeBlockHash hash
+            , _syncStateBlockPayloadHash = either error id $ runGetEitherS decodeBlockPayloadHash payloadHash
+            }
+        | otherwise = error $ "wrong type; expected " <> sshow expectedType <> " but got " <> sshow type'
+    readRow expectedType invalidRow
+        = error $ "invalid row: expected " <> sshow expectedType <> " but got row " <> sshow invalidRow
+
+getPayloadsAfter :: HasCallStack => SQLiteEnv -> Parent BlockHeight -> ExceptT LocatedSQ3Error IO [Ranked BlockPayloadHash]
+getPayloadsAfter db parentHeight = do
+    qry db "SELECT blockheight, payloadhash FROM BlockHistory2 WHERE blockheight > ?"
+        [SInt (fromIntegral @BlockHeight @Int64 (unwrapParent parentHeight))]
+        [RInt, RBlob] >>= traverse
+          \case
+              [SInt bh, SBlob bhash] ->
+                  return $! Ranked (fromIntegral @Int64 @BlockHeight bh) $ either error id $ runGetEitherS decodeBlockPayloadHash bhash
+              _ -> error "incorrect column type"
+
+-- | Get the checkpointer's idea of the earliest block. The block height
+-- is the height of the block of the block hash.
+getEarliestBlock :: HasCallStack => SQLiteEnv -> ExceptT LocatedSQ3Error IO (Maybe RankedBlockHash)
+getEarliestBlock db = do
+    r <- qry db qtext [] [RInt, RBlob] >>= mapM go
+    case r of
+        [] -> return Nothing
+        (!o:_) -> return (Just o)
+    where
+    qtext = "SELECT blockheight, hash FROM BlockHistory2 ORDER BY blockheight ASC LIMIT 1"
+
+    go [SInt hgt, SBlob blob] =
+        let hash = either error id $ runGetEitherS decodeBlockHash blob
+        in return (RankedBlockHash (fromIntegral hgt) hash)
+    go _ = fail "Chainweb.Pact.Backend.RelationalCheckpointer.doGetEarliest: impossible. This is a bug in chainweb-node."
+
+-- | Get the checkpointer's idea of the latest block.
+getLatestBlock :: HasCallStack => SQLiteEnv -> ExceptT LocatedSQ3Error IO (Maybe SyncState)
+getLatestBlock db = do
+    r <- qry db qtext [] [RInt, RBlob, RBlob] >>= mapM go
+    case r of
+        [] -> return Nothing
+        (!o:_) -> return (Just o)
+    where
+    qtext = "SELECT blockheight, hash, payloadhash FROM BlockHistory2 ORDER BY blockheight DESC LIMIT 1"
+
+    go [SInt hgt, SBlob blob, SBlob pBlob] =
+        let hash = either error id $ runGetEitherS decodeBlockHash blob
+        in let pHash = either error id $ runGetEitherS decodeBlockPayloadHash pBlob
+        in return $ SyncState
+            { _syncStateBlockHash = hash
+            , _syncStateBlockPayloadHash = pHash
+            , _syncStateHeight = int hgt
+            }
+    go r = fail $
+        "Chainweb.Pact.Backend.ChainwebPactDb.getLatestBlock: impossible. This is a bug in chainweb-node. Details: "
+        <> sshow r
+
+lookupBlockWithHeight :: HasCallStack => SQ3.Database -> BlockHeight -> ExceptT LocatedSQ3Error IO (Maybe (Ranked BlockHash))
+lookupBlockWithHeight db bheight = do
+    qry db qtext [SInt $ fromIntegral bheight] [RBlob] >>= \case
+        [[SBlob hash]] -> return $! Just $!
+            Ranked bheight (either error id $ runGetEitherS decodeBlockHash hash)
+        [] -> return Nothing
+        res -> error $ "Invalid result, " <> sshow res
+    where
+    qtext = "SELECT hash FROM BlockHistory2 WHERE blockheight = ?;"
+
+lookupBlockHash :: HasCallStack => SQ3.Database -> BlockHash -> ExceptT LocatedSQ3Error IO (Maybe BlockHeight)
+lookupBlockHash db hash = do
+    qry db qtext [SBlob (runPutS (encodeBlockHash hash))] [RInt] >>= \case
+        [[SInt n]] -> return $! Just $! int n
+        [] -> return $ Nothing
+        res -> error $ "Invalid result, " <> sshow res
+    where
+   qtext = "SELECT blockheight FROM BlockHistory2 WHERE hash = ?;"
+
+lookupRankedBlockHash :: HasCallStack => SQ3.Database -> RankedBlockHash -> IO Bool
+lookupRankedBlockHash db rankedBHash = throwOnDbError $ do
+    qry db qtext
+        [ SInt $ fromIntegral (_rankedBlockHashHeight rankedBHash)
+        , SBlob $ runPutS $ encodeBlockHash $ _rankedBlockHashHash rankedBHash
+        ] [RInt] >>= \case
+        [[SInt n]] -> return $! n == 1
+        res -> error $ "Invalid result, " <> sshow res
+    where
+    qtext = "SELECT COUNT(*) FROM BlockHistory2 WHERE blockheight = ? AND hash = ?;"
+
 data LocatedSQ3Error = LocatedSQ3Error !CallStack !SQ3.Error
 instance Show LocatedSQ3Error where
     show (LocatedSQ3Error cs e) =

src/Chainweb/Pact/PactService.hs

@@ -184,7 +184,7 @@ initialPayloadState
     -> IO ()
 initialPayloadState logger serviceEnv = do
     withSavepoint (_psReadWriteSql serviceEnv) RunGenesisSavePoint $ do
-        latestBlock <- fmap _consensusStateLatest <$> Checkpointer.getConsensusState rwSql
+        latestBlock <- Checkpointer.getLatestBlock rwSql
         case latestBlock of
             Nothing -> runGenesis
             Just ss
@@ -497,7 +497,7 @@ syncToFork
     -> IO ConsensusState
 syncToFork logger serviceEnv hints forkInfo = do
     (rewoundTxs, validatedTxs, newConsensusState) <- withSavepoint sql ValidateBlockSavePoint $ do
-        pactConsensusState <- fromJuste <$> Checkpointer.getConsensusState sql
+        pactConsensusState <- Checkpointer.getConsensusState sql
         let atTarget =
                 _syncStateBlockHash (_consensusStateLatest pactConsensusState) ==
                     _latestBlockHash (forkInfo._forkInfoTargetState)