diff --git a/src/Chainweb/Pact/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact/Backend/ChainwebPactDb.hs index 6a410d67ba..8bb63075ae 100644 --- a/src/Chainweb/Pact/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact/Backend/ChainwebPactDb.hs @@ -761,57 +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 - 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 () @@ -886,81 +835,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 = ?;" diff --git a/src/Chainweb/Pact/Backend/Utils.hs b/src/Chainweb/Pact/Backend/Utils.hs index 14220dcf87..8de00ed42f 100644 --- a/src/Chainweb/Pact/Backend/Utils.hs +++ b/src/Chainweb/Pact/Backend/Utils.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -39,6 +40,14 @@ module Chainweb.Pact.Backend.Utils , getEndTxId -- * Transactions , withTransaction + , setConsensusState + , getConsensusState + , getPayloadsAfter + , getLatestBlock + , getEarliestBlock + , lookupBlockWithHeight + , lookupBlockHash + , lookupRankedBlockHash -- * SQLite conversions and assertions , toUtf8 , fromUtf8 @@ -76,6 +85,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 @@ -98,6 +108,7 @@ import Pact.Types.Util (AsString(..)) import Chainweb.Logger import Chainweb.Pact.Backend.SQLite.DirectV2 +import Chainweb.PayloadProvider import Chainweb.Version import Chainweb.Utils @@ -448,6 +459,127 @@ 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 + 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) = diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 2ab7cea1aa..912f487e68 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -215,8 +215,8 @@ runGenesisIfNeeded -> ServiceEnv tbl -> IO () runGenesisIfNeeded logger serviceEnv = do - withTransaction (_psReadWriteSql serviceEnv) $ do - latestBlock <- fmap _consensusStateLatest <$> Checkpointer.getConsensusState (_psReadWriteSql serviceEnv) + withTransaction rwSql $ do + latestBlock <- Checkpointer.getLatestBlock rwSql when (maybe True (isGenesisBlockHeader' cid . Parent . _syncStateBlockHash) latestBlock) $ do logFunctionText logger Debug "running genesis" let genesisBlockHash = genesisBlockHeader cid ^. blockHash @@ -231,7 +231,7 @@ runGenesisIfNeeded logger serviceEnv = do Just p -> p maybeErr <- runExceptT - $ Checkpointer.restoreAndSave logger cid (_psReadWriteSql serviceEnv) (genesisRankedParentBlockHash cid) + $ Checkpointer.restoreAndSave logger cid rwSql (genesisRankedParentBlockHash cid) $ NEL.singleton $ ( if pact5 cid (genesisHeight cid) @@ -253,7 +253,7 @@ runGenesisIfNeeded logger serviceEnv = do (_payloadStoreTable $ _psPdb serviceEnv) (genesisHeight cid) genesisPayload - Checkpointer.setConsensusState (_psReadWriteSql serviceEnv) targetSyncState + Checkpointer.setConsensusState rwSql targetSyncState -- we can't produce pact 4 blocks anymore, so don't make -- payloads if pact 4 is on when (pact5 cid (succ $ genesisHeight cid)) $ @@ -272,6 +272,7 @@ runGenesisIfNeeded logger serviceEnv = do startPayloadRefresher logger serviceEnv emptyBlock where + rwSql = _psReadWriteSql serviceEnv cid = _chainId serviceEnv -- | only for use in generating genesis blocks in tools. @@ -527,7 +528,7 @@ syncToFork -> IO ConsensusState syncToFork logger serviceEnv hints forkInfo = do (rewoundTxs, validatedTxs, newConsensusState) <- withTransaction sql $ do - pactConsensusState <- fromJuste <$> Checkpointer.getConsensusState sql + pactConsensusState <- Checkpointer.getConsensusState sql let atTarget = _syncStateBlockHash (_consensusStateLatest pactConsensusState) == _latestBlockHash forkInfo._forkInfoTargetState diff --git a/src/Chainweb/Pact/PactService/Checkpointer.hs b/src/Chainweb/Pact/PactService/Checkpointer.hs index bd653c8589..8947e78cb8 100644 --- a/src/Chainweb/Pact/PactService/Checkpointer.hs +++ b/src/Chainweb/Pact/PactService/Checkpointer.hs @@ -43,6 +43,7 @@ module Chainweb.Pact.PactService.Checkpointer -- , findLatestValidBlockHeader -- , exitOnRewindLimitExceeded , getEarliestBlock + , getLatestBlock -- , lookupBlock , lookupRankedBlockHash , lookupBlockHash @@ -71,8 +72,7 @@ import Chainweb.Logger import Chainweb.MinerReward import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Backend.Utils -import Chainweb.Pact.Backend.Utils qualified as PactDb +import Chainweb.Pact.Backend.Utils qualified as Backend.Utils import Chainweb.Pact.Types import Chainweb.Parent import Chainweb.PayloadProvider @@ -137,8 +137,9 @@ readFromNthParent -> IO (Historical a) readFromNthParent logger cid sql parentCreationTime n doRead = do latest <- - _consensusStateLatest . fromMaybe (error "readFromNthParent is illegal to call before genesis") - <$> getConsensusState sql + fmap (fromMaybe (error "readFromNthParent is illegal to call before genesis")) + $ ChainwebPactDb.throwOnDbError + $ ChainwebPactDb.getLatestBlock sql if genesisHeight cid + fromIntegral @Word @BlockHeight n > _syncStateHeight latest then do logFunctionText logger Warn $ "readFromNthParent asked to rewind beyond genesis, to " @@ -147,12 +148,12 @@ readFromNthParent logger cid sql parentCreationTime n doRead = do else do let targetHeight = _syncStateHeight latest - fromIntegral @Word @BlockHeight n lookupBlockWithHeight sql targetHeight >>= \case - -- this case for shallow nodes without enough history - Nothing -> do - logFunctionText logger Warn "readFromNthParent asked to rewind beyond known blocks" - return NoHistory - Just nthBlock -> - readFrom logger cid sql parentCreationTime (Parent nthBlock) doRead + -- this case for shallow nodes without enough history + Nothing -> do + logFunctionText logger Warn "readFromNthParent asked to rewind beyond known blocks" + return NoHistory + Just nthBlock -> + readFrom logger cid sql parentCreationTime (Parent nthBlock) doRead -- read-only rewind to a target block. -- if that target block is missing, return Nothing. @@ -174,50 +175,50 @@ readFrom logger cid sql parentCreationTime parent pactRead = do , _bctxMinerReward = blockMinerReward (childBlockHeight cid parent) , _bctxChainId = cid } - liftIO $ do - !latestHeader <- maybe (genesisRankedParentBlockHash cid) (Parent . _syncStateRankedBlockHash . _consensusStateLatest) <$> - ChainwebPactDb.throwOnDbError (ChainwebPactDb.getConsensusState sql) - -- is the parent the latest header, i.e., can we get away without rewinding? - let parentIsLatestHeader = latestHeader == parent - let currentHeight = _bctxCurrentBlockHeight blockCtx - PactDb.getEndTxId cid sql parent >>= traverse \startTxId -> - if pact5 cid currentHeight then do - let - blockHandlerEnv = ChainwebPactDb.BlockHandlerEnv - { ChainwebPactDb._blockHandlerDb = sql - , ChainwebPactDb._blockHandlerLogger = logger - , ChainwebPactDb._blockHandlerChainId = cid - , ChainwebPactDb._blockHandlerBlockHeight = currentHeight - , ChainwebPactDb._blockHandlerMode = Pact.Transactional - , ChainwebPactDb._blockHandlerUpperBoundTxId = startTxId - , ChainwebPactDb._blockHandlerAtTip = parentIsLatestHeader - } - let pactDb = ChainwebPactDb.chainwebPactBlockDb blockHandlerEnv - let blockEnv = BlockEnv blockCtx pactDb - pact5Read pactRead blockEnv (emptyBlockHandle startTxId) - else do - let pact4TxId = Pact4.TxId (coerce startTxId) - let blockHandlerEnv = Pact4.mkBlockHandlerEnv cid currentHeight sql logger - newBlockDbEnv <- liftIO $ newMVar $ Pact4.BlockDbEnv - blockHandlerEnv - -- FIXME not sharing the cache - (Pact4.initBlockState defaultModuleCacheLimit pact4TxId) - let pactDb = Pact4.rewoundPactDb currentHeight pact4TxId + !latestHeader <- ChainwebPactDb.throwOnDbError + $ fmap (maybe (genesisRankedParentBlockHash cid) (Parent . _syncStateRankedBlockHash)) + $ ChainwebPactDb.getLatestBlock sql + -- is the parent the latest header, i.e., can we get away without rewinding? + let parentIsLatestHeader = latestHeader == parent + let currentHeight = _bctxCurrentBlockHeight blockCtx + Backend.Utils.getEndTxId cid sql parent >>= traverse \startTxId -> + if pact5 cid currentHeight then do + let + blockHandlerEnv = ChainwebPactDb.BlockHandlerEnv + { ChainwebPactDb._blockHandlerDb = sql + , ChainwebPactDb._blockHandlerLogger = logger + , ChainwebPactDb._blockHandlerChainId = cid + , ChainwebPactDb._blockHandlerBlockHeight = currentHeight + , ChainwebPactDb._blockHandlerMode = Pact.Transactional + , ChainwebPactDb._blockHandlerUpperBoundTxId = startTxId + , ChainwebPactDb._blockHandlerAtTip = parentIsLatestHeader + } + let pactDb = ChainwebPactDb.chainwebPactBlockDb blockHandlerEnv + let blockEnv = BlockEnv blockCtx pactDb + pact5Read pactRead blockEnv (emptyBlockHandle startTxId) + else do + let pact4TxId = Pact4.TxId (coerce startTxId) + let blockHandlerEnv = Pact4.mkBlockHandlerEnv cid currentHeight sql logger + newBlockDbEnv <- liftIO $ newMVar $ Pact4.BlockDbEnv + blockHandlerEnv + -- FIXME not sharing the cache + (Pact4.initBlockState defaultModuleCacheLimit pact4TxId) + let pactDb = Pact4.rewoundPactDb currentHeight pact4TxId - let pact4DbEnv = Pact4.CurrentBlockDbEnv - { _cpPactDbEnv = Pact4.PactDbEnv pactDb newBlockDbEnv - , _cpRegisterProcessedTx = \hash -> - Pact4.runBlockDbEnv newBlockDbEnv (Pact4.indexPactTransaction $ BS.fromShort $ Pact4.unHash $ Pact4.unRequestKey hash) - , _cpLookupProcessedTx = \hs -> do - res <- doLookupSuccessful sql currentHeight (coerce hs) - return - $ HashMap.mapKeys coerce - $ HashMap.map - (\(T3 height _payloadhash bhash) -> T2 height bhash) - res - , _cpHeaderOracle = Pact4.headerOracleForBlock blockHandlerEnv - } - pact4Read pactRead (Pact4.BlockEnv blockCtx pact4DbEnv) + let pact4DbEnv = Pact4.CurrentBlockDbEnv + { _cpPactDbEnv = Pact4.PactDbEnv pactDb newBlockDbEnv + , _cpRegisterProcessedTx = \hash -> + Pact4.runBlockDbEnv newBlockDbEnv (Pact4.indexPactTransaction $ BS.fromShort $ Pact4.unHash $ Pact4.unRequestKey hash) + , _cpLookupProcessedTx = \hs -> do + res <- Backend.Utils.doLookupSuccessful sql currentHeight (coerce hs) + return + $ HashMap.mapKeys coerce + $ HashMap.map + (\(T3 height _payloadhash bhash) -> T2 height bhash) + res + , _cpHeaderOracle = Pact4.headerOracleForBlock blockHandlerEnv + } + pact4Read pactRead (Pact4.BlockEnv blockCtx pact4DbEnv) -- the special case where one doesn't want to extend the chain, just rewind it. rewindTo @@ -227,7 +228,7 @@ rewindTo -> Parent RankedBlockHash -> IO () rewindTo cid sql ancestor = do - void $ PactDb.rewindDbTo cid sql ancestor + void $ Backend.Utils.rewindDbTo cid sql ancestor data PactRead a = PactRead @@ -282,7 +283,7 @@ restoreAndSave -> m q restoreAndSave logger cid sql parent blocks = do -- TODO PP: check first if we're rewinding past "final" point? same with rewindTo above. - startTxId <- liftIO $ PactDb.rewindDbTo cid sql parent + startTxId <- liftIO $ Backend.Utils.rewindDbTo cid sql parent let startBlockHeight = childBlockHeight cid parent foldState1 (fmap executeBlock blocks) (T2 startBlockHeight startTxId) where @@ -304,7 +305,7 @@ restoreAndSave logger cid sql parent blocks = do , _cpRegisterProcessedTx = \hash -> Pact4.runBlockDbEnv newBlockDbEnv (Pact4.indexPactTransaction $ BS.fromShort $ Pact4.unHash $ Pact4.unRequestKey hash) , _cpLookupProcessedTx = \hs -> do - res <- doLookupSuccessful sql currentBlockHeight (coerce hs) + res <- Backend.Utils.doLookupSuccessful sql currentBlockHeight (coerce hs) return $ HashMap.mapKeys coerce $ HashMap.map @@ -367,25 +368,29 @@ getEarliestBlock :: SQLiteEnv -> IO (Maybe RankedBlockHash) getEarliestBlock sql = do ChainwebPactDb.throwOnDbError $ ChainwebPactDb.getEarliestBlock sql -getConsensusState :: SQLiteEnv -> IO (Maybe ConsensusState) +getLatestBlock :: SQLiteEnv -> IO (Maybe SyncState) +getLatestBlock sql = do + ChainwebPactDb.throwOnDbError $ Backend.Utils.getLatestBlock sql + +getConsensusState :: SQLiteEnv -> IO ConsensusState getConsensusState sql = do - ChainwebPactDb.throwOnDbError $ ChainwebPactDb.getConsensusState sql + ChainwebPactDb.throwOnDbError $ Backend.Utils.getConsensusState sql setConsensusState :: SQLiteEnv -> ConsensusState -> IO () setConsensusState sql cs = do - ChainwebPactDb.throwOnDbError $ ChainwebPactDb.setConsensusState sql cs + ChainwebPactDb.throwOnDbError $ Backend.Utils.setConsensusState sql cs lookupBlockWithHeight :: HasCallStack => SQLiteEnv -> BlockHeight -> IO (Maybe (Ranked BlockHash)) lookupBlockWithHeight sql bh = do - ChainwebPactDb.throwOnDbError $ ChainwebPactDb.lookupBlockWithHeight sql bh + ChainwebPactDb.throwOnDbError $ Backend.Utils.lookupBlockWithHeight sql bh lookupBlockHash :: HasCallStack => SQLiteEnv -> BlockHash -> IO (Maybe BlockHeight) lookupBlockHash sql pbh = do - ChainwebPactDb.throwOnDbError $ ChainwebPactDb.lookupBlockHash sql pbh + ChainwebPactDb.throwOnDbError $ Backend.Utils.lookupBlockHash sql pbh getPayloadsAfter :: SQLiteEnv -> Parent BlockHeight -> IO [Ranked BlockPayloadHash] getPayloadsAfter sql b = do - ChainwebPactDb.throwOnDbError $ ChainwebPactDb.getPayloadsAfter sql b + ChainwebPactDb.throwOnDbError $ Backend.Utils.getPayloadsAfter sql b -- -------------------------------------------------------------------------- -- -- Utils