diff --git a/bench/Chainweb/Pact/Backend/Bench.hs b/bench/Chainweb/Pact/Backend/Bench.hs index 0968229ee9..a25ec8feb7 100644 --- a/bench/Chainweb/Pact/Backend/Bench.hs +++ b/bench/Chainweb/Pact/Backend/Bench.hs @@ -71,7 +71,7 @@ cpRestoreAndSave :: (Monoid q) => Checkpointer logger -> Maybe BlockHeader - -> [(BlockHeader, ChainwebPactDbEnv logger -> IO q)] + -> [(BlockHeader, Pact4Db logger -> IO q)] -> IO q cpRestoreAndSave cp pc blks = snd <$> _cpRestoreAndSave cp (ParentHeader <$> pc) (traverse Stream.yield [RunnableBlock $ \dbEnv _ -> (,bh) <$> fun (_cpPactDbEnv dbEnv) | (bh, fun) <- blks]) diff --git a/chainweb.cabal b/chainweb.cabal index e45ddb50f3..cdacc8fff9 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -317,10 +317,10 @@ library , Chainweb.Pact.Backend.Types , Chainweb.Pact.Backend.Utils , Chainweb.Pact.Conversion - , Chainweb.Pact.NoCoinbase , Chainweb.Pact.PactService , Chainweb.Pact.PactService.Checkpointer - , Chainweb.Pact.PactService.ExecBlock + , Chainweb.Pact.PactService.Pact4.ExecBlock + , Chainweb.Pact.PactService.Pact5.ExecBlock , Chainweb.Pact.RestAPI , Chainweb.Pact.RestAPI.Client , Chainweb.Pact.RestAPI.EthSpv @@ -331,9 +331,11 @@ library , Chainweb.Pact.Service.PactInProcApi , Chainweb.Pact.Service.PactQueue , Chainweb.Pact.Service.Types + , Chainweb.Pact4.NoCoinbase , Chainweb.Pact4.Templates , Chainweb.Pact4.TransactionExec , Chainweb.Pact4.Validations + , Chainweb.Pact5.NoCoinbase , Chainweb.Pact5.Templates , Chainweb.Pact5.TransactionExec , Chainweb.Pact5.Types diff --git a/src/Chainweb/BlockHeader.hs b/src/Chainweb/BlockHeader.hs index d7266a97b5..c5ccd7a6b4 100644 --- a/src/Chainweb/BlockHeader.hs +++ b/src/Chainweb/BlockHeader.hs @@ -98,6 +98,8 @@ module Chainweb.BlockHeader , adjacentChainIds , absBlockHeightDiff +, guardBlockHeader + -- * IsBlockHeader , IsBlockHeader(..) @@ -1188,3 +1190,7 @@ workSizeBytes -> BlockHeight -> Natural workSizeBytes v h = headerSizeBytes v (unsafeChainId 0) h - 32 + +-- | TODO document +guardBlockHeader :: (ChainwebVersion -> ChainId -> BlockHeight -> a) -> BlockHeader -> a +guardBlockHeader k bh = k (_chainwebVersion bh) (_chainId bh) (_blockHeight bh) diff --git a/src/Chainweb/Chainweb/Configuration.hs b/src/Chainweb/Chainweb/Configuration.hs index 6aeb533feb..1272954986 100644 --- a/src/Chainweb/Chainweb/Configuration.hs +++ b/src/Chainweb/Chainweb/Configuration.hs @@ -613,25 +613,14 @@ parseVersion = constructVersion constructVersion cliVersion fub bd disablePow' oldVersion = winningVersion & versionBlockDelay .~ fromMaybe (_versionBlockDelay winningVersion) bd & versionForks %~ HM.filterWithKey (\fork _ -> fork <= fromMaybe maxBound fub) - & versionPact4Upgrades .~ - maybe (_versionPact4Upgrades winningVersion) (\fub' -> + & versionUpgrades .~ + maybe (_versionUpgrades winningVersion) (\fub' -> OnChains $ HM.mapWithKey (\cid _ -> case winningVersion ^?! versionForks . at fub' . _Just . onChain cid of ForkNever -> error "Chainweb.Chainweb.Configuration.parseVersion: the fork upper bound never occurs in this version." - ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) (winningVersion ^?! versionPact4Upgrades . onChain cid) - ForkAtGenesis -> winningVersion ^?! versionPact4Upgrades . onChain cid - ) - (HS.toMap (chainIds winningVersion)) - ) fub - & versionPact5Upgrades .~ - maybe (_versionPact5Upgrades winningVersion) (\fub' -> - OnChains $ HM.mapWithKey - (\cid _ -> - case winningVersion ^?! versionForks . at fub' . _Just . onChain cid of - ForkNever -> error "Chainweb.Chainweb.Configuration.parseVersion: the fork upper bound never occurs in this version." - ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) (winningVersion ^?! versionPact5Upgrades . onChain cid) - ForkAtGenesis -> winningVersion ^?! versionPact5Upgrades . onChain cid + ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) (winningVersion ^?! versionUpgrades . onChain cid) + ForkAtGenesis -> winningVersion ^?! versionUpgrades . onChain cid ) (HS.toMap (chainIds winningVersion)) ) fub diff --git a/src/Chainweb/Chainweb/MinerResources.hs b/src/Chainweb/Chainweb/MinerResources.hs index b911939bc8..eb44974290 100644 --- a/src/Chainweb/Chainweb/MinerResources.hs +++ b/src/Chainweb/Chainweb/MinerResources.hs @@ -154,7 +154,9 @@ withMiningCoordination logger conf cdb inner WorkStale -> return Nothing forM_ mContinuableBlockInProgress $ \continuableBlockInProgress -> do - maybeNewBlock <- _pactContinueBlock pact cid continuableBlockInProgress + maybeNewBlock <- case continuableBlockInProgress of + ForPact4 block -> fmap ForPact4 <$> _pactContinueBlock pact cid block + ForPact5 block -> fmap ForPact5 <$> _pactContinueBlock pact cid block -- if continuing returns NoHistory then the parent header -- isn't available in the checkpointer right now. -- in that case we just mark the payload as not stale. @@ -164,7 +166,10 @@ withMiningCoordination logger conf cdb inner logFunctionText (chainLogger cid logger) Debug $ "refreshed block, old and new tx count: " - <> sshow (V.length $ _transactionPairs $ _blockInProgressTransactions continuableBlockInProgress, V.length $ _transactionPairs $ _blockInProgressTransactions newBlock) + <> sshow + ( forAnyPactVersion (V.length . _transactionPairs . _blockInProgressTransactions) continuableBlockInProgress + , forAnyPactVersion (V.length . _transactionPairs . _blockInProgressTransactions) newBlock + ) atomically $ modifyTVar' tpw $ workForMiner ourMiner cid .~ WorkReady (NewBlockInProgress newBlock) diff --git a/src/Chainweb/Miner/RestAPI/Server.hs b/src/Chainweb/Miner/RestAPI/Server.hs index e2d6698bf5..12fe380ff9 100644 --- a/src/Chainweb/Miner/RestAPI/Server.hs +++ b/src/Chainweb/Miner/RestAPI/Server.hs @@ -206,7 +206,7 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d (WorkStale, WorkStale) -> retry (WorkAlreadyMined _, WorkAlreadyMined _) -> retry - (WorkReady (NewBlockInProgress lastBip), WorkReady (NewBlockInProgress currentBip)) + (WorkReady (NewBlockInProgress (ForPact4 lastBip)), WorkReady (NewBlockInProgress (ForPact4 currentBip))) | ParentHeader lastPh <- _blockInProgressParentHeader lastBip , ParentHeader currentPh <- _blockInProgressParentHeader currentBip , lastPh /= currentPh -> @@ -230,6 +230,32 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d -- no apparent change | otherwise -> retry + + (WorkReady (NewBlockInProgress (ForPact5 lastBip)), WorkReady (NewBlockInProgress (ForPact5 currentBip))) + | ParentHeader lastPh <- _blockInProgressParentHeader lastBip + , ParentHeader currentPh <- _blockInProgressParentHeader currentBip + , lastPh /= currentPh -> + -- we've got a new block on a new parent, we must've missed + -- the update where the old block became outdated. + -- miner should restart + return (WorkOutdated, currentBlockOnChain) + + | lastTlen <- V.length (_transactionPairs $ _blockInProgressTransactions lastBip) + , currentTlen <- V.length (_transactionPairs $ _blockInProgressTransactions currentBip) + , lastTlen /= currentTlen -> + if currentTlen < lastTlen + then + -- our refreshed block somehow has less transactions, + -- but the same parent header, log this as a bizarre case + return (WorkRegressed, currentBlockOnChain) + else + -- we've got a block that's been extended with new transactions + -- miner should restart + return (WorkRefreshed, currentBlockOnChain) + + -- no apparent change + | otherwise -> retry + (WorkReady (NewBlockPayload lastPh lastPwo), WorkReady (NewBlockPayload currentPh currentPwo)) | lastPh /= currentPh -> -- we've got a new block on a new parent, we must've missed @@ -245,6 +271,7 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d -- no apparent change | otherwise -> retry + (WorkReady _, WorkReady _) -> error "awaitNewPrimedWork: impossible: NewBlockInProgress replaced by a NewBlockPayload" diff --git a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs index 75a9552351..f3373d5530 100644 --- a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs +++ b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs @@ -151,7 +151,7 @@ doReadFrom -> SQLiteEnv -> MVar (DbCache PersistModuleData) -> Maybe ParentHeader - -> (CurrentBlockDbEnv logger -> IO a) + -> (CurrentBlockDbEnv logger (DynamicPactDb logger) -> IO a) -> IO (Historical a) doReadFrom logger v cid sql moduleCacheVar maybeParent doRead = do let currentHeight = case maybeParent of @@ -209,7 +209,7 @@ doRestoreAndSave -> IntraBlockPersistence -> MVar (DbCache PersistModuleData) -> Maybe ParentHeader - -> Stream (Of (RunnableBlock logger q)) IO r + -> Stream (Of (RunnableBlock logger (DynamicPactDb logger) q)) IO r -> IO (r, q) doRestoreAndSave logger v cid sql p moduleCacheVar rewindParent blocks = do modifyMVar moduleCacheVar $ \moduleCache -> do diff --git a/src/Chainweb/Pact/Backend/Types.hs b/src/Chainweb/Pact/Backend/Types.hs index 2be4d5c32b..5ae0680ed9 100644 --- a/src/Chainweb/Pact/Backend/Types.hs +++ b/src/Chainweb/Pact/Backend/Types.hs @@ -37,6 +37,9 @@ module Chainweb.Pact.Backend.Types , _cpRewindTo , ReadCheckpointer(..) , CurrentBlockDbEnv(..) + , cpPactDbEnv + , cpRegisterProcessedTx + , cpLookupProcessedTx , DynamicPactDb(..) , makeDynamicPactDb , assertDynamicPact4Db @@ -48,8 +51,8 @@ module Chainweb.Pact.Backend.Types , pdbcLogDir , pdbcPersistDir , pdbcPragmas - , ChainwebPactDbEnv - , CoreDb + , Pact4Db + , Pact5Db , SQLiteRowDelta(..) , SQLitePendingTableCreations @@ -325,8 +328,8 @@ newtype BlockHandler logger a = BlockHandler , MonadReader (BlockHandlerEnv logger) ) -type ChainwebPactDbEnv logger = PactDbEnv (BlockEnv logger) -type CoreDb = Pact5.PactDb Pact5.CoreBuiltin Pact5.Info +type Pact4Db logger = PactDbEnv (BlockEnv logger) +type Pact5Db = Pact5.PactDb Pact5.CoreBuiltin Pact5.Info type ParentHash = BlockHash @@ -334,7 +337,7 @@ type ParentHash = BlockHash data ReadCheckpointer logger = ReadCheckpointer { _cpReadFrom :: !(forall a. Maybe ParentHeader -> - (CurrentBlockDbEnv logger -> IO a) -> IO (Historical a)) + (CurrentBlockDbEnv logger (DynamicPactDb logger) -> IO a) -> IO (Historical a)) -- ^ rewind to a particular block *in-memory*, producing a read-write snapshot -- ^ of the database at that block to compute some value, after which the snapshot -- is discarded and nothing is saved to the database. @@ -361,8 +364,8 @@ data ReadCheckpointer logger = ReadCheckpointer -- | A callback which writes a block's data to the input database snapshot, -- and knows its parent header (Nothing if it's a genesis block). -- Reports back its own header and some extra value. -newtype RunnableBlock logger a = RunnableBlock - { runBlock :: CurrentBlockDbEnv logger -> Maybe ParentHeader -> IO (a, BlockHeader) } +newtype RunnableBlock db logger a = RunnableBlock + { runBlock :: CurrentBlockDbEnv db logger -> Maybe ParentHeader -> IO (a, BlockHeader) } -- | One makes requests to the checkpointer to query the pact state at the -- current block or any earlier block, to extend the pact state with new blocks, and @@ -372,7 +375,7 @@ data Checkpointer logger = Checkpointer !(forall q r. (HasCallStack, Monoid q) => Maybe ParentHeader -> - Stream (Of (RunnableBlock logger q)) IO r -> + Stream (Of (RunnableBlock logger (DynamicPactDb logger) q)) IO r -> IO (r, q)) -- ^ rewind to a particular block, and play a stream of blocks afterward, -- extending the chain and saving the result persistently. for example, @@ -408,30 +411,30 @@ data Checkpointer logger = Checkpointer _cpRewindTo :: Checkpointer logger -> Maybe ParentHeader -> IO () _cpRewindTo cp ancestor = void $ _cpRestoreAndSave cp ancestor - (pure () :: Stream (Of (RunnableBlock logger ())) IO ()) + (pure () :: Stream (Of (RunnableBlock logger (DynamicPactDb logger) ())) IO ()) -data DynamicPactDb logger = Pact4Db (ChainwebPactDbEnv logger) | Pact5Db CoreDb +data DynamicPactDb logger = Pact4Db (Pact4Db logger) | Pact5Db Pact5Db makeDynamicPactDb :: ChainwebVersion -> ChainId -> BlockHeight - -> ChainwebPactDbEnv logger -> CoreDb + -> Pact4Db logger -> Pact5Db -> DynamicPactDb logger makeDynamicPactDb v cid bh pact4Db pact5Db | pact5 v cid bh = Pact5Db pact5Db | otherwise = Pact4Db pact4Db -- TODO: make both of these errors InternalErrors, without incurring an import cycle -assertDynamicPact4Db :: HasCallStack => DynamicPactDb logger -> IO (ChainwebPactDbEnv logger) +assertDynamicPact4Db :: (MonadThrow m, HasCallStack) => DynamicPactDb logger -> m (Pact4Db logger) assertDynamicPact4Db (Pact4Db pact4Db) = return pact4Db assertDynamicPact4Db (Pact5Db _pact5Db) = error "expected Pact4 DB, got Pact5 DB" -assertDynamicPact5Db :: HasCallStack => DynamicPactDb logger -> IO CoreDb +assertDynamicPact5Db :: (MonadThrow m, HasCallStack) => DynamicPactDb logger -> m Pact5Db assertDynamicPact5Db (Pact5Db pact5Db) = return pact5Db assertDynamicPact5Db (Pact4Db _pact4Db) = error "expected Pact5 DB, got Pact4 DB" -- this is effectively a read-write snapshot of the Pact state at a block. -data CurrentBlockDbEnv logger = CurrentBlockDbEnv - { _cpPactDbEnv :: !(DynamicPactDb logger) +data CurrentBlockDbEnv logger db = CurrentBlockDbEnv + { _cpPactDbEnv :: !db , _cpRegisterProcessedTx :: !(P.PactHash -> IO ()) , _cpLookupProcessedTx :: !(Vector P.PactHash -> IO (HashMap P.PactHash (T2 BlockHeight BlockHash))) @@ -500,3 +503,4 @@ data Historical a deriving anyclass NFData makePrisms ''Historical +makeLenses ''CurrentBlockDbEnv diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index d2dc5e8fed..08781aa974 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -110,7 +110,7 @@ import Chainweb.Mempool.Mempool as Mempool import Chainweb.Miner.Pact import Chainweb.Pact.Backend.RelationalCheckpointer (withProdRelationalCheckpointer) import Chainweb.Pact.Backend.Types -import Chainweb.Pact.PactService.ExecBlock +import Chainweb.Pact.PactService.Pact4.ExecBlock import Chainweb.Pact.PactService.Checkpointer import Chainweb.Pact.Service.PactQueue (PactQueue, getNextRequest) import Chainweb.Pact.Service.Types @@ -127,6 +127,7 @@ import Chainweb.Version import Chainweb.Version.Guards import Utils.Logging.Trace import Chainweb.Counter +import qualified Chainweb.Pact.PactService.Pact4.ExecBlock as Pact4 runPactService @@ -256,12 +257,11 @@ initializeCoinContract v cid pwo = do logWarn "initializeCoinContract: Checkpointer returned no latest block. Starting from genesis." validateGenesis Just currentBlockHeader -> do - -- We check the block hash because it's more principled and - -- we don't have to compute it, so the comparison is still relatively - -- cheap. We could also check the height but that would be redundant. - if _blockHash (_parentHeader currentBlockHeader) /= _blockHash genesisHeader + if + _parentHeader currentBlockHeader /= genesisHeader && + not (pact5 v cid $ _blockHeight (_parentHeader currentBlockHeader)) then do - !mc <- readFrom (Just currentBlockHeader) Pact4.readInitModules >>= \case + !mc <- readFrom (Just currentBlockHeader) (assertBlockPact4 Pact4.readInitModules) >>= \case NoHistory -> throwM $ BlockHeaderLookupFailure $ "initializeCoinContract: internal error: latest block not found: " <> sshow currentBlockHeader Historical mc -> return mc @@ -474,7 +474,7 @@ execNewBlock -> Miner -> NewBlockFill -> ParentHeader - -> PactServiceM logger tbl (Historical BlockInProgress) + -> PactServiceM logger tbl (Historical (ForSomePactVersion BlockInProgress)) execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do readFrom (Just newBlockParent) $ do blockDbEnv <- view psBlockDbEnv @@ -485,267 +485,55 @@ execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do logInfo $ "(parent height = " <> sshow pHeight <> ")" <> " (parent hash = " <> sshow pHash <> ")" blockGasLimit <- view (psServiceEnv . psBlockGasLimit) - initCache <- initModuleCacheForBlock False - coinbaseOutput <- - runPact4Coinbase False miner (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) initCache - finalBlockState <- fmap _benvBlockState - $ liftIO - $ readMVar - $ pdPactDbVar - $ pactDb - let blockInProgress = BlockInProgress - { _blockInProgressModuleCache = initCache - -- ^ we do not use the module cache populated by coinbase in - -- subsequent transactions - , _blockInProgressPendingData = _bsPendingBlock finalBlockState - , _blockInProgressTxId = _bsTxId finalBlockState - , _blockInProgressParentHeader = newBlockParent - , _blockInProgressRemainingGasLimit = fromIntegral blockGasLimit - , _blockInProgressTransactions = Transactions - { _transactionCoinbase = coinbaseOutput - , _transactionPairs = mempty - } - , _blockInProgressMiner = miner - } - case fill of - NewBlockFill -> continueBlock mpAccess blockInProgress - NewBlockEmpty -> return blockInProgress + if pact5 v cid (succ pHeight) then do + assertBlockPact5 $ do + undefined + else assertBlockPact4 $ do + initCache <- initModuleCacheForBlock False + coinbaseOutput <- runPact4Coinbase False miner (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) initCache + finalBlockState <- fmap _benvBlockState + $ liftIO + $ readMVar + $ pdPactDbVar + $ pactDb + let blockInProgress = BlockInProgress + { _blockInProgressModuleCache = Pact4ModuleCache initCache + -- ^ we do not use the module cache populated by coinbase in + -- subsequent transactions + , _blockInProgressPendingData = _bsPendingBlock finalBlockState + , _blockInProgressTxId = _bsTxId finalBlockState + , _blockInProgressParentHeader = newBlockParent + , _blockInProgressRemainingGasLimit = fromIntegral blockGasLimit + , _blockInProgressTransactions = Transactions + { _transactionCoinbase = coinbaseOutput + , _transactionPairs = mempty + } + , _blockInProgressMiner = miner + , _blockInProgressPactVersion = Pact4T + } + case fill of + NewBlockFill -> undefined -- continueBlock mpAccess Pact4T blockInProgress + NewBlockEmpty -> return (ForPact4 blockInProgress) + where + v = _chainwebVersion newBlockParent + cid = _chainId newBlockParent execContinueBlock - :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl) + :: forall logger tbl pv. (Logger logger, CanReadablePayloadCas tbl) => MemPoolAccess - -> BlockInProgress - -> PactServiceM logger tbl (Historical BlockInProgress) + -> BlockInProgress pv + -> PactServiceM logger tbl (Historical (BlockInProgress pv)) execContinueBlock mpAccess blockInProgress = pactLabel "execNewBlock" $ do - readFrom (Just newBlockParent) $ continueBlock mpAccess blockInProgress + readFrom (Just newBlockParent) $ + case _blockInProgressPactVersion blockInProgress of + Pact4T -> assertBlockPact4 $ Pact4.continueBlock mpAccess blockInProgress + Pact5T -> undefined where newBlockParent = _blockInProgressParentHeader blockInProgress --- | Note: The ParentHeader param here is the PARENT HEADER of the new --- block-to-be. --- -continueBlock - :: forall logger tbl - . (Logger logger, CanReadablePayloadCas tbl) - => MemPoolAccess - -> BlockInProgress - -> PactBlockM logger tbl BlockInProgress -continueBlock mpAccess blockInProgress = do - updateMempool - liftPactServiceM $ - logInfo $ "(parent height = " <> sshow pHeight <> ")" - <> " (parent hash = " <> sshow pHash <> ")" - - blockDbEnv <- view psBlockDbEnv - pactDb <- liftIO $ assertDynamicPact4Db (_cpPactDbEnv blockDbEnv) - -- restore the block state from the block being continued - liftIO $ - modifyMVar_ (pdPactDbVar pactDb) $ \blockEnv -> - return - $! blockEnv - & benvBlockState . bsPendingBlock .~ _blockInProgressPendingData blockInProgress - & benvBlockState . bsTxId .~ _blockInProgressTxId blockInProgress - - blockGasLimit <- view (psServiceEnv . psBlockGasLimit) - - let - txTimeHeadroomFactor :: Double - txTimeHeadroomFactor = 5 - -- 2.5 microseconds per unit gas - txTimeLimit :: Micros - txTimeLimit = round $ (2.5 * txTimeHeadroomFactor) * fromIntegral blockGasLimit - - let initCache = _blockInProgressModuleCache blockInProgress - let cb = _transactionCoinbase (_blockInProgressTransactions blockInProgress) - let startTxs = _transactionPairs (_blockInProgressTransactions blockInProgress) - - successes <- liftIO $ Vec.fromFoldable startTxs - failures <- liftIO $ Vec.new @_ @_ @TransactionHash - - let initState = BlockFill - (_blockInProgressRemainingGasLimit blockInProgress) - (S.fromList $ requestKeyToTransactionHash . P._crReqKey . snd <$> V.toList startTxs) - 0 - - -- Heuristic: limit fetches to count of 1000-gas txs in block. - let fetchLimit = fromIntegral $ blockGasLimit `div` 1000 - T2 - finalModuleCache - BlockFill { _bfTxHashes = requestKeys, _bfGasLimit = finalGasLimit } - <- refill fetchLimit txTimeLimit successes failures initCache initState - - liftPactServiceM $ logInfo $ "(request keys = " <> sshow requestKeys <> ")" - - liftIO $ do - txHashes <- Vec.toLiftedVector failures - mpaBadlistTx mpAccess txHashes - - txs <- liftIO $ Vec.toLiftedVector successes - -- edmund: we need to be careful about timeouts. - -- If a tx times out, it must not be in the block state, otherwise - -- the "block in progress" will contain pieces of state from that tx. - -- - -- this cannot happen now because applyPactCmd doesn't let it. - finalBlockState <- fmap _benvBlockState - $ liftIO - $ readMVar - $ pdPactDbVar - $ pactDb - let !blockInProgress' = BlockInProgress - { _blockInProgressModuleCache = finalModuleCache - , _blockInProgressPendingData = _bsPendingBlock finalBlockState - , _blockInProgressTxId = _bsTxId finalBlockState - , _blockInProgressParentHeader = newBlockParent - , _blockInProgressRemainingGasLimit = finalGasLimit - , _blockInProgressTransactions = Transactions - { _transactionCoinbase = cb - , _transactionPairs = txs - } - , _blockInProgressMiner = _blockInProgressMiner blockInProgress - } - return blockInProgress' - where - newBlockParent = _blockInProgressParentHeader blockInProgress - !parentTime = - ParentCreationTime (_blockCreationTime $ _parentHeader newBlockParent) - - getBlockTxs :: BlockFill -> PactBlockM logger tbl (Vector Pact4.Transaction) - getBlockTxs bfState = do - dbEnv <- view psBlockDbEnv - psEnv <- ask - logger <- view (psServiceEnv . psLogger) - let validate bhi _bha txs = do - results <- do - let v = _chainwebVersion psEnv - cid = _chainId psEnv - validateChainwebTxs logger v cid dbEnv parentTime bhi txs return - - V.forM results $ \case - Right _ -> return True - Left _e -> return False - - liftIO $! - mpaGetBlock mpAccess bfState validate (pHeight + 1) pHash (_parentHeader newBlockParent) - - refill - :: Word64 - -> Micros - -> GrowableVec (Pact4.Transaction, P.CommandResult [P.TxLogJson]) - -> GrowableVec TransactionHash - -> ModuleCache -> BlockFill - -> PactBlockM logger tbl (T2 ModuleCache BlockFill) - refill fetchLimit txTimeLimit successes failures = go - where - go :: ModuleCache -> BlockFill -> PactBlockM logger tbl (T2 ModuleCache BlockFill) - go mc unchanged@bfState = do - - case unchanged of - BlockFill g _ c -> do - (goodLength, badLength) <- liftIO $ (,) <$> Vec.length successes <*> Vec.length failures - liftPactServiceM $ logDebug $ "Block fill: count=" <> sshow c - <> ", gaslimit=" <> sshow g <> ", good=" - <> sshow goodLength <> ", bad=" <> sshow badLength - - -- LOOP INVARIANT: limit absolute recursion count - if _bfCount bfState > fetchLimit then liftPactServiceM $ do - logInfo $ "Refill fetch limit exceeded (" <> sshow fetchLimit <> ")" - pure (T2 mc unchanged) - else do - when (_bfGasLimit bfState < 0) $ - throwM $ MempoolFillFailure $ "Internal error, negative gas limit: " <> sshow bfState - - if _bfGasLimit bfState == 0 then pure (T2 mc unchanged) else do - - newTrans <- getBlockTxs bfState - if V.null newTrans then pure (T2 mc unchanged) else do - - T2 pairs mc' <- - execTransactionsOnly - (_blockInProgressMiner blockInProgress) - newTrans - mc - (Just txTimeLimit) - - oldSuccessesLength <- liftIO $ Vec.length successes - - (newState, timedOut) <- splitResults successes failures unchanged (V.toList pairs) - - -- LOOP INVARIANT: gas must not increase - when (_bfGasLimit newState > _bfGasLimit bfState) $ - throwM $ MempoolFillFailure $ "Gas must not increase: " <> sshow (bfState,newState) - - newSuccessesLength <- liftIO $ Vec.length successes - let addedSuccessCount = newSuccessesLength - oldSuccessesLength - - if timedOut - then - -- a transaction timed out, so give up early and make the block - pure (T2 mc' (incCount newState)) - else if (_bfGasLimit newState >= _bfGasLimit bfState) && addedSuccessCount > 0 - then - -- INVARIANT: gas must decrease if any transactions succeeded - throwM $ MempoolFillFailure - $ "Invariant failure, gas did not decrease: " - <> sshow (bfState,newState,V.length newTrans,addedSuccessCount) - else - go mc' (incCount newState) - - incCount :: BlockFill -> BlockFill - incCount b = over bfCount succ b - - -- | Split the results of applying each command into successes and failures, - -- and return the final 'BlockFill'. - -- - -- If we encounter a 'TxTimeout', we short-circuit, and only return - -- what we've put into the block before the timeout. We also report - -- that we timed out, so that `refill` can stop early. - -- - -- The failed txs are later badlisted. - splitResults :: () - => GrowableVec (Pact4.Transaction, P.CommandResult [P.TxLogJson]) - -> GrowableVec TransactionHash -- ^ failed txs - -> BlockFill - -> [(Pact4.Transaction, Either CommandInvalidError (P.CommandResult [P.TxLogJson]))] - -> PactBlockM logger tbl (BlockFill, Bool) - splitResults successes failures = go - where - go acc@(BlockFill g rks i) = \case - [] -> pure (acc, False) - (t, r) : rest -> case r of - Right cr -> do - !rks' <- enforceUnique rks (requestKeyToTransactionHash $ P._crReqKey cr) - -- Decrement actual gas used from block limit - let !g' = g - fromIntegral (P._crGas cr) - liftIO $ Vec.push successes (t, cr) - go (BlockFill g' rks' i) rest - Left (CommandInvalidGasPurchaseFailure (Pact4GasPurchaseFailure h _)) -> do - !rks' <- enforceUnique rks h - -- Gas buy failure adds failed request key to fail list only - liftIO $ Vec.push failures h - go (BlockFill g rks' i) rest - Left (CommandInvalidGasPurchaseFailure (Pact5GasPurchaseFailure h _)) -> - error "Pact5GasPurchaseFailure" - Left (CommandInvalidTxTimeout (TxTimeout h)) -> do - liftIO $ Vec.push failures h - liftPactServiceM $ logError $ "timed out on " <> sshow h - return (acc, True) - - enforceUnique rks rk - | S.member rk rks = - throwM $ MempoolFillFailure $ "Duplicate transaction: " <> sshow rk - | otherwise = return $ S.insert rk rks - - pHeight = _blockHeight $ _parentHeader newBlockParent - pHash = _blockHash $ _parentHeader newBlockParent - - updateMempool = liftIO $ do - mpaProcessFork mpAccess $ _parentHeader newBlockParent - mpaSetLastHeader mpAccess $ _parentHeader newBlockParent - -type GrowableVec = Vec (PrimState IO) - --- | only for use in generating genesis blocks in tools +-- | only for use in generating genesis blocks in tools. +-- only supports Pact 4. -- execNewGenesisBlock :: (Logger logger, CanReadablePayloadCas tbl) @@ -755,11 +543,12 @@ execNewGenesisBlock execNewGenesisBlock miner newTrans = pactLabel "execNewGenesisBlock" $ do historicalBlock <- readFrom Nothing $ do -- NEW GENESIS COINBASE: Reject bad coinbase, use date rule for precompilation - results <- execTransactions True miner newTrans - (EnforceCoinbaseFailure True) - (CoinbaseUsePrecompiled False) Nothing Nothing - >>= throwCommandInvalidError - return $! toPayloadWithOutputs miner results + results <- assertBlockPact4 $ + execTransactions True miner newTrans + (EnforceCoinbaseFailure True) + (CoinbaseUsePrecompiled False) Nothing Nothing + >>= throwCommandInvalidError + return $! toPayloadWithOutputs Pact4T miner results case historicalBlock of NoHistory -> internalError "PactService.execNewGenesisBlock: Impossible error, unable to rewind before genesis" Historical block -> return block @@ -837,7 +626,7 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ liftIO $ writeIORef heightRef (_blockHeight bh) payload <- liftIO $ fromJuste <$> lookupPayloadDataWithHeight pdb (Just $ _blockHeight bh) (_blockPayloadHash bh) - void $ execBlock bh (CheckablePayload payload) + void $ assertBlockPact4 $ Pact4.execBlock bh (CheckablePayload payload) ) validationFailed <- readIORef validationFailedRef when validationFailed $ @@ -1032,14 +821,14 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " <> ". BlockPayloadHash: " <> encodeToText (_blockPayloadHash forkBh) <> ". Block: " <> encodeToText (ObjectEncoded forkBh) Just x -> return $ payloadWithOutputsToPayloadData x - void $ execBlock forkBh (CheckablePayload payload) + void $ assertBlockPact4 $ Pact4.execBlock forkBh (CheckablePayload payload) return ([], forkBh) ) forkBlockHeaders -- run the new block, the one we're validating, and -- validate its hashes let runThisBlock = Stream.yield $ do - !output <- execBlock headerToValidate payloadToValidate + !output <- assertBlockPact4 $ Pact4.execBlock headerToValidate payloadToValidate return ([output], headerToValidate) -- here we rewind to the common ancestor block, run the @@ -1120,13 +909,14 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do let act = readFromLatest $ do pdb <- view psBlockDbEnv + db' <- traverseOf cpPactDbEnv assertDynamicPact4Db pdb pc <- view psParentHeader let parentTime = ParentCreationTime (_blockCreationTime $ _parentHeader pc) currHeight = succ $ _blockHeight $ _parentHeader pc v = _chainwebVersion pc cid = _chainId pc - liftIO $ validateChainwebTxs logger v cid pdb parentTime currHeight txs + liftIO $ Pact4.validateChainwebTxs logger v cid db' parentTime currHeight txs (evalPactServiceM psState psEnv . runPactBlockM pc pdb . attemptBuyGas noMiner) withPactState $ \run -> timeoutYield timeoutLimit (run act) >>= \case @@ -1140,7 +930,7 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do :: forall logger tbl. (Logger logger) => Miner -> Vector (Either InsertError Pact4.Transaction) - -> PactBlockM logger tbl (Vector (Either InsertError Pact4.Transaction)) + -> PactBlockM logger (DynamicPactDb logger) tbl (Vector (Either InsertError Pact4.Transaction)) attemptBuyGas miner txsOrErrs = localLabelBlock ("transaction", "attemptBuyGas") $ do mc <- getInitCache l <- view (psServiceEnv . psLogger) @@ -1149,7 +939,7 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do buyGasFor :: logger -> T2 (DL.DList (Either InsertError Pact4.Transaction)) ModuleCache -> Either InsertError Pact4.Transaction - -> PactBlockM logger tbl (T2 (DL.DList (Either InsertError Pact4.Transaction)) ModuleCache) + -> PactBlockM logger (DynamicPactDb logger) tbl (T2 (DL.DList (Either InsertError Pact4.Transaction)) ModuleCache) buyGasFor _l (T2 dl mcache) err@Left {} = return (T2 (DL.snoc dl err) mcache) buyGasFor l (T2 dl mcache) (Right tx) = do T2 mcache' !res <- do diff --git a/src/Chainweb/Pact/PactService/Checkpointer.hs b/src/Chainweb/Pact/PactService/Checkpointer.hs index dd2c3089e9..653acf4258 100644 --- a/src/Chainweb/Pact/PactService/Checkpointer.hs +++ b/src/Chainweb/Pact/PactService/Checkpointer.hs @@ -60,7 +60,7 @@ import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Pact.Backend.Types -import Chainweb.Pact.PactService.ExecBlock +import Chainweb.Pact.PactService.Pact4.ExecBlock import Chainweb.Pact.Service.Types import Chainweb.Pact.Types import Chainweb.Payload @@ -68,6 +68,9 @@ import Chainweb.Payload.PayloadStore import Chainweb.TreeDB (getBranchIncreasing, forkEntry, lookup, seekAncestor) import Chainweb.Utils hiding (check) import Chainweb.Version +import qualified Chainweb.Pact.PactService.Pact4.ExecBlock as Pact4 +import Chainweb.Version.Guards (pact5) +import Control.Lens.Internal.Zoom (Effect(..)) exitOnRewindLimitExceeded :: PactServiceM logger tbl a -> PactServiceM logger tbl a @@ -95,7 +98,7 @@ exitOnRewindLimitExceeded = handle $ \case -- note: this function will never rewind before genesis. readFromLatest :: Logger logger - => PactBlockM logger tbl a + => PactBlockM logger (DynamicPactDb logger) tbl a -> PactServiceM logger tbl a readFromLatest doRead = readFromNthParent 0 doRead @@ -105,7 +108,7 @@ readFromNthParent :: forall logger tbl a . Logger logger => Word - -> PactBlockM logger tbl a + -> PactBlockM logger (DynamicPactDb logger) tbl a -> PactServiceM logger tbl a readFromNthParent n doRead = go 0 where @@ -141,7 +144,9 @@ readFromNthParent n doRead = go 0 -- if that target block is missing, return Nothing. readFrom :: Logger logger - => Maybe ParentHeader -> PactBlockM logger tbl a -> PactServiceM logger tbl (Historical a) + => Maybe ParentHeader + -> PactBlockM logger (DynamicPactDb logger) tbl a + -> PactServiceM logger tbl (Historical a) readFrom ph doRead = do cp <- view psCheckpointer pactParent <- getPactParent ph @@ -166,7 +171,7 @@ getPactParent ph = do restoreAndSave :: (CanReadablePayloadCas tbl, Logger logger, Monoid q) => Maybe ParentHeader - -> Stream (Of (PactBlockM logger tbl (q, BlockHeader))) IO r + -> Stream (Of (PactBlockM logger (DynamicPactDb logger) tbl (q, BlockHeader))) IO r -> PactServiceM logger tbl (r, q) restoreAndSave ph blocks = do cp <- view psCheckpointer @@ -293,7 +298,14 @@ rewindToIncremental rewindLimit (ParentHeader parent) = do <> ". Block: "<> encodeToText (ObjectEncoded blockHeader) Just x -> return $ payloadWithOutputsToPayloadData x liftIO $ writeIORef heightRef (_blockHeight blockHeader) - void $ execBlock blockHeader (CheckablePayload payload) + env <- ask + if guardBlockHeader pact5 blockHeader + then error "pact 5 block" + else do + env' <- env & traverseOf (psBlockDbEnv . cpPactDbEnv) assertDynamicPact4Db + void $ magnify (to (const env')) $ + Pact4.execBlock blockHeader (CheckablePayload payload) + return (Last (Just blockHeader), blockHeader) -- double check output hash here? ) diff --git a/src/Chainweb/Pact/PactService/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs similarity index 68% rename from src/Chainweb/Pact/PactService/ExecBlock.hs rename to src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index bd58927168..b38b552394 100644 --- a/src/Chainweb/Pact/PactService/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -8,9 +8,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} -- | --- Module: Chainweb.Pact.PactService.ExecBlock +-- Module: Chainweb.Pact.PactService.Pact4.ExecBlock -- Copyright: Copyright © 2020 Kadena LLC. -- License: See LICENSE file -- Maintainers: Lars Kuhtz, Emily Pillmore, Stuart Popejoy @@ -18,10 +20,11 @@ -- -- Functionality for playing block transactions. -- -module Chainweb.Pact.PactService.ExecBlock +module Chainweb.Pact.PactService.Pact4.ExecBlock ( execBlock , execTransactions , execTransactionsOnly + , continueBlock , minerReward , toPayloadWithOutputs , validateChainwebTxs @@ -84,10 +87,10 @@ import Chainweb.Logger import Chainweb.Mempool.Mempool as Mempool import Chainweb.Miner.Pact import Chainweb.Pact.Backend.Types -import Chainweb.Pact.NoCoinbase import Chainweb.Pact.Service.Types import Chainweb.Pact.SPV import Chainweb.Pact.Types +import Chainweb.Pact4.NoCoinbase import qualified Chainweb.Pact4.Transaction as Pact4 import qualified Chainweb.Pact5.Transaction as Pact5 import qualified Chainweb.Pact4.TransactionExec as Pact4 @@ -100,6 +103,12 @@ import Chainweb.Time import Chainweb.Utils hiding (check) import Chainweb.Version import Chainweb.Version.Guards +import Data.Coerce +import Data.Word +import GrowableVector.Lifted (Vec) +import Control.Monad.Primitive +import qualified GrowableVector.Lifted as Vec +import qualified Data.Set as S -- | Execute a block -- only called in validate either for replay or for validating current block. @@ -112,7 +121,7 @@ execBlock -- header when we should use the respective values from the parent header -- instead. -> CheckablePayload - -> PactBlockM logger tbl (P.Gas, PayloadWithOutputs) + -> PactBlockM logger (Pact4Db logger) tbl (P.Gas, PayloadWithOutputs) execBlock currHeader payload = do let plData = checkablePayloadToPayloadData payload dbEnv <- view psBlockDbEnv @@ -181,8 +190,8 @@ execBlock currHeader payload = do (EnforceCoinbaseFailure False) (CoinbaseUsePrecompiled False) blockGasLimit Nothing throwCommandInvalidError - :: Transactions (Either CommandInvalidError a) - -> PactBlockM logger tbl (Transactions a) + :: Transactions Pact4 (Either CommandInvalidError a) + -> PactBlockM logger (Pact4Db logger) tbl (Transactions Pact4 a) throwCommandInvalidError = (transactionPairs . traverse . _2) throwGasFailure where throwGasFailure = \case @@ -204,7 +213,7 @@ validateChainwebTxs => logger -> ChainwebVersion -> ChainId - -> CurrentBlockDbEnv logger + -> CurrentBlockDbEnv logger (Pact4Db logger) -> ParentCreationTime -- ^ reference time for tx validation. -> BlockHeight @@ -307,7 +316,7 @@ execTransactions -> CoinbaseUsePrecompiled -> Maybe P.Gas -> Maybe Micros - -> PactBlockM logger tbl (Transactions (Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) + -> PactBlockM logger (Pact4Db logger) tbl (Transactions Pact4 (Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) execTransactions isGenesis miner ctxs enfCBFail usePrecomp gasLimit timeLimit = do mc <- initModuleCacheForBlock isGenesis -- for legacy reasons (ask Emily) we don't use the module cache resulting @@ -322,13 +331,13 @@ execTransactionsOnly -> Vector Pact4.Transaction -> ModuleCache -> Maybe Micros - -> PactBlockM logger tbl + -> PactBlockM logger (Pact4Db logger) tbl (T2 (Vector (Pact4.Transaction, Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) ModuleCache) execTransactionsOnly miner ctxs mc txTimeLimit = do T2 txOuts mcOut <- applyPactCmds False ctxs miner mc Nothing txTimeLimit return $! T2 (V.force (V.zip ctxs txOuts)) mcOut -initModuleCacheForBlock :: (Logger logger) => Bool -> PactBlockM logger tbl ModuleCache +initModuleCacheForBlock :: (Logger logger) => Bool -> PactBlockM logger (Pact4Db logger) tbl ModuleCache initModuleCacheForBlock isGenesis = do PactServiceState{..} <- get pbh <- views psParentHeader (_blockHeight . _parentHeader) @@ -351,7 +360,7 @@ runPact4Coinbase -> EnforceCoinbaseFailure -> CoinbaseUsePrecompiled -> ModuleCache - -> PactBlockM logger tbl (P.CommandResult [P.TxLogJson]) + -> PactBlockM logger (Pact4Db logger) tbl (P.CommandResult [P.TxLogJson]) runPact4Coinbase True _ _ _ _ = return noCoinbase runPact4Coinbase False miner enfCBFail usePrecomp mc = do logger <- view (psServiceEnv . psLogger) @@ -363,7 +372,7 @@ runPact4Coinbase False miner enfCBFail usePrecomp mc = do reward <- liftIO $! minerReward v rs bh dbEnv <- view psBlockDbEnv - pactDb <- liftIO $ assertDynamicPact4Db $ _cpPactDbEnv dbEnv + let pactDb = _cpPactDbEnv dbEnv T2 cr upgradedCacheM <- liftIO $ Pact4.applyCoinbase v logger pactDb reward txCtx enfCBFail usePrecomp mc @@ -372,11 +381,11 @@ runPact4Coinbase False miner enfCBFail usePrecomp mc = do return $! cr where - upgradeInitCache newCache = do liftPactServiceM $ logInfo "Updating init cache for upgrade" updateInitCacheM newCache + data CommandInvalidError = CommandInvalidGasPurchaseFailure !GasPurchaseFailure | CommandInvalidTxTimeout !TxTimeout @@ -392,7 +401,7 @@ applyPactCmds -> ModuleCache -> Maybe P.Gas -> Maybe Micros - -> PactBlockM logger tbl (T2 (Vector (Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) ModuleCache) + -> PactBlockM logger (Pact4Db logger) tbl (T2 (Vector (Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) ModuleCache) applyPactCmds isGenesis cmds miner startModuleCache blockGas txTimeLimit = do let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to P._crGas) txs (txOuts, T2 mcOut _) <- tracePactBlockM' "applyPactCmds" () (txsGas . fst) $ @@ -405,7 +414,7 @@ applyPactCmds isGenesis cmds miner startModuleCache blockGas txTimeLimit = do -> [Pact4.Transaction] -> StateT (T2 ModuleCache (Maybe P.Gas)) - (PactBlockM logger tbl) + (PactBlockM logger (Pact4Db logger) tbl) [Either CommandInvalidError (P.CommandResult [P.TxLogJson])] go !acc = \case [] -> do @@ -428,11 +437,11 @@ applyPactCmd -> Pact4.Transaction -> StateT (T2 ModuleCache (Maybe P.Gas)) - (PactBlockM logger tbl) + (PactBlockM logger (Pact4Db logger) tbl) (Either CommandInvalidError (P.CommandResult [P.TxLogJson])) applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do dbEnv <- view psBlockDbEnv - pactDb <- liftIO $ assertDynamicPact4Db $ _cpPactDbEnv dbEnv + let pactDb = _cpPactDbEnv dbEnv prevBlockState <- liftIO $ fmap _benvBlockState $ readMVar $ pdPactDbVar pactDb logger <- view (psServiceEnv . psLogger) @@ -528,24 +537,6 @@ pact4TransactionsFromPayload ppv plData = do toCWTransaction bs = evaluate (force (codecDecode (Pact4.payloadCodec ppv) $ _transactionBytes bs)) --- pact5TransactionsFromPayload --- :: Pact4.PactParserVersion --- -> PayloadData --- -> IO (Vector Pact5.Transaction) --- pact5TransactionsFromPayload ppv plData = do --- vtrans <- fmap V.fromList $ --- mapM toCWTransaction $ --- toList (_payloadDataTransactions plData) --- let (theLefts, theRights) = partitionEithers $ V.toList vtrans --- unless (null theLefts) $ do --- let ls = map T.pack theLefts --- throwM $ TransactionDecodeFailure $ "Failed to decode pact transactions: " --- <> T.intercalate ". " ls --- return $! V.fromList theRights --- where --- toCWTransaction bs = evaluate (force (codecDecode (pact5PayloadCodec ppv) $ --- _transactionBytes bs)) - debugResult :: J.Encode a => Logger logger => Text -> a -> PactServiceM logger tbl () debugResult msg result = logDebug $ trunc $ msg <> " result: " <> J.encodeText result @@ -592,7 +583,7 @@ validateHashes -- ^ Current Header -> CheckablePayload -> Miner - -> Transactions (P.CommandResult [P.TxLogJson]) + -> Transactions Pact4 (P.CommandResult [P.TxLogJson]) -> Either PactException PayloadWithOutputs validateHashes bHeader payload miner transactions = if newHash == prevHash @@ -605,7 +596,7 @@ validateHashes bHeader payload miner transactions = ] where - pwo = toPayloadWithOutputs miner transactions + pwo = toPayloadWithOutputs Pact4T miner transactions newHash = _payloadWithOutputsPayloadHash pwo prevHash = _blockPayloadHash bHeader @@ -679,3 +670,225 @@ validateHashes bHeader payload miner transactions = toPairCR cr = over (P.crLogs . _Just) (CRLogPair (fromJuste $ P._crLogs (toHashCommandResult cr))) cr + +type GrowableVec = Vec (PrimState IO) + +-- | Continue adding transactions to an existing block. +continueBlock + :: forall logger tbl + . (Logger logger, CanReadablePayloadCas tbl) + => MemPoolAccess + -> BlockInProgress Pact4 + -> PactBlockM logger (Pact4Db logger) tbl (BlockInProgress Pact4) +continueBlock mpAccess blockInProgress = do + updateMempool + liftPactServiceM $ + logInfo $ "(parent height = " <> sshow pHeight <> ")" + <> " (parent hash = " <> sshow pHash <> ")" + + blockDbEnv <- view psBlockDbEnv + let pactDb = _cpPactDbEnv blockDbEnv + -- restore the block state from the block being continued + liftIO $ + modifyMVar_ (pdPactDbVar pactDb) $ \blockEnv -> + return + $! blockEnv + & benvBlockState . bsPendingBlock .~ _blockInProgressPendingData blockInProgress + & benvBlockState . bsTxId .~ _blockInProgressTxId blockInProgress + + blockGasLimit <- view (psServiceEnv . psBlockGasLimit) + + let + txTimeHeadroomFactor :: Double + txTimeHeadroomFactor = 5 + -- 2.5 microseconds per unit gas + txTimeLimit :: Micros + txTimeLimit = round $ (2.5 * txTimeHeadroomFactor) * fromIntegral blockGasLimit + + let Pact4ModuleCache initCache = _blockInProgressModuleCache blockInProgress + let cb = _transactionCoinbase (_blockInProgressTransactions blockInProgress) + let startTxs = _transactionPairs (_blockInProgressTransactions blockInProgress) + + successes <- liftIO $ Vec.fromFoldable startTxs + failures <- liftIO $ Vec.new @_ @_ @TransactionHash + + let initState = BlockFill + (_blockInProgressRemainingGasLimit blockInProgress) + (S.fromList $ requestKeyToTransactionHash . P._crReqKey . snd <$> V.toList startTxs) + 0 + + -- Heuristic: limit fetches to count of 1000-gas txs in block. + let fetchLimit = fromIntegral $ blockGasLimit `div` 1000 + T2 + finalModuleCache + BlockFill { _bfTxHashes = requestKeys, _bfGasLimit = finalGasLimit } + <- refill fetchLimit txTimeLimit successes failures initCache initState + + liftPactServiceM $ logInfo $ "(request keys = " <> sshow requestKeys <> ")" + + liftIO $ do + txHashes <- Vec.toLiftedVector failures + mpaBadlistTx mpAccess txHashes + + txs <- liftIO $ Vec.toLiftedVector successes + -- edmund: we need to be careful about timeouts. + -- If a tx times out, it must not be in the block state, otherwise + -- the "block in progress" will contain pieces of state from that tx. + -- + -- this cannot happen now because applyPactCmd doesn't let it. + finalBlockState <- fmap _benvBlockState + $ liftIO + $ readMVar + $ pdPactDbVar + $ pactDb + let !blockInProgress' = BlockInProgress + { _blockInProgressModuleCache = Pact4ModuleCache finalModuleCache + , _blockInProgressPendingData = _bsPendingBlock finalBlockState + , _blockInProgressTxId = _bsTxId finalBlockState + , _blockInProgressParentHeader = newBlockParent + , _blockInProgressRemainingGasLimit = finalGasLimit + , _blockInProgressTransactions = Transactions + { _transactionCoinbase = cb + , _transactionPairs = txs + } + , _blockInProgressMiner = _blockInProgressMiner blockInProgress + , _blockInProgressPactVersion = Pact4T + } + return blockInProgress' + where + newBlockParent = _blockInProgressParentHeader blockInProgress + + !parentTime = + ParentCreationTime (_blockCreationTime $ _parentHeader newBlockParent) + + getBlockTxs :: BlockFill -> PactBlockM logger (Pact4Db logger) tbl (Vector Pact4.Transaction) + getBlockTxs bfState = do + dbEnv <- view psBlockDbEnv + psEnv <- ask + logger <- view (psServiceEnv . psLogger) + let validate bhi _bha txs = do + results <- do + let v = _chainwebVersion psEnv + cid = _chainId psEnv + validateChainwebTxs logger v cid dbEnv parentTime bhi txs return + + V.forM results $ \case + Right _ -> return True + Left _e -> return False + + liftIO $! + mpaGetBlock mpAccess bfState validate (pHeight + 1) pHash (_parentHeader newBlockParent) + + refill + :: Word64 + -> Micros + -> GrowableVec (Pact4.Transaction, P.CommandResult [P.TxLogJson]) + -> GrowableVec TransactionHash + -> ModuleCache -> BlockFill + -> PactBlockM logger (Pact4Db logger) tbl (T2 ModuleCache BlockFill) + refill fetchLimit txTimeLimit successes failures = go + where + go :: ModuleCache -> BlockFill -> PactBlockM logger (Pact4Db logger) tbl (T2 ModuleCache BlockFill) + go mc unchanged@bfState = do + + case unchanged of + BlockFill g _ c -> do + (goodLength, badLength) <- liftIO $ (,) <$> Vec.length successes <*> Vec.length failures + liftPactServiceM $ logDebug $ "Block fill: count=" <> sshow c + <> ", gaslimit=" <> sshow g <> ", good=" + <> sshow goodLength <> ", bad=" <> sshow badLength + + -- LOOP INVARIANT: limit absolute recursion count + if _bfCount bfState > fetchLimit then liftPactServiceM $ do + logInfo $ "Refill fetch limit exceeded (" <> sshow fetchLimit <> ")" + pure (T2 mc unchanged) + else do + when (_bfGasLimit bfState < 0) $ + throwM $ MempoolFillFailure $ "Internal error, negative gas limit: " <> sshow bfState + + if _bfGasLimit bfState == 0 then pure (T2 mc unchanged) else do + + newTrans <- getBlockTxs bfState + if V.null newTrans then pure (T2 mc unchanged) else do + + T2 pairs mc' <- execTransactionsOnly + (_blockInProgressMiner blockInProgress) + newTrans + mc + (Just txTimeLimit) + + oldSuccessesLength <- liftIO $ Vec.length successes + + (newState, timedOut) <- splitResults successes failures unchanged (V.toList pairs) + + -- LOOP INVARIANT: gas must not increase + when (_bfGasLimit newState > _bfGasLimit bfState) $ + throwM $ MempoolFillFailure $ "Gas must not increase: " <> sshow (bfState,newState) + + newSuccessesLength <- liftIO $ Vec.length successes + let addedSuccessCount = newSuccessesLength - oldSuccessesLength + + if timedOut + then + -- a transaction timed out, so give up early and make the block + pure (T2 mc' (incCount newState)) + else if (_bfGasLimit newState >= _bfGasLimit bfState) && addedSuccessCount > 0 + then + -- INVARIANT: gas must decrease if any transactions succeeded + throwM $ MempoolFillFailure + $ "Invariant failure, gas did not decrease: " + <> sshow (bfState,newState,V.length newTrans,addedSuccessCount) + else + go mc' (incCount newState) + + incCount :: BlockFill -> BlockFill + incCount b = over bfCount succ b + + -- | Split the results of applying each command into successes and failures, + -- and return the final 'BlockFill'. + -- + -- If we encounter a 'TxTimeout', we short-circuit, and only return + -- what we've put into the block before the timeout. We also report + -- that we timed out, so that `refill` can stop early. + -- + -- The failed txs are later badlisted. + splitResults :: () + => GrowableVec (Pact4.Transaction, P.CommandResult [P.TxLogJson]) + -> GrowableVec TransactionHash -- ^ failed txs + -> BlockFill + -> [(Pact4.Transaction, Either CommandInvalidError (P.CommandResult [P.TxLogJson]))] + -> PactBlockM logger (Pact4Db logger) tbl (BlockFill, Bool) + splitResults successes failures = go + where + go acc@(BlockFill g rks i) = \case + [] -> pure (acc, False) + (t, r) : rest -> case r of + Right cr -> do + !rks' <- enforceUnique rks (requestKeyToTransactionHash $ P._crReqKey cr) + -- Decrement actual gas used from block limit + let !g' = g - fromIntegral (P._crGas cr) + liftIO $ Vec.push successes (t, cr) + go (BlockFill g' rks' i) rest + Left (CommandInvalidGasPurchaseFailure (Pact4GasPurchaseFailure h _)) -> do + !rks' <- enforceUnique rks h + -- Gas buy failure adds failed request key to fail list only + liftIO $ Vec.push failures h + go (BlockFill g rks' i) rest + Left (CommandInvalidGasPurchaseFailure (Pact5GasPurchaseFailure h _)) -> + error "Pact5GasPurchaseFailure" + Left (CommandInvalidTxTimeout (TxTimeout h)) -> do + liftIO $ Vec.push failures h + liftPactServiceM $ logError $ "timed out on " <> sshow h + return (acc, True) + + enforceUnique rks rk + | S.member rk rks = + throwM $ MempoolFillFailure $ "Duplicate transaction: " <> sshow rk + | otherwise = return $ S.insert rk rks + + pHeight = _blockHeight $ _parentHeader newBlockParent + pHash = _blockHash $ _parentHeader newBlockParent + + updateMempool = liftIO $ do + mpaProcessFork mpAccess $ _parentHeader newBlockParent + mpaSetLastHeader mpAccess $ _parentHeader newBlockParent diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs new file mode 100644 index 0000000000..d17a11e7c6 --- /dev/null +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Chainweb.Pact.PactService.Pact5.ExecBlock + ( + + ) where + +import Chainweb.Logger +import Chainweb.Miner.Pact +import Chainweb.Pact.Service.Types +import Chainweb.Pact.Types hiding (ctxCurrentBlockHeight, TxContext(..)) +import qualified Chainweb.Pact5.Transaction as Pact5 +import Chainweb.Payload +import Data.ByteString (ByteString) +import Data.Decimal +import Data.Vector (Vector) +import Data.Void +import qualified Pact.Core.Command.Types as Pact5 +import qualified Pact.Core.Persistence as Pact5 +import qualified Pact.Parse as Pact4 +import Chainweb.Pact5.NoCoinbase +import Control.Lens +import Chainweb.Version +import Data.Default +import Control.Monad.IO.Class +import Chainweb.BlockHeight +import qualified Data.Map as Map +import Chainweb.Utils (int, Codec (..)) +import Numeric.Natural +import qualified Chainweb.Pact5.TransactionExec as Pact5 +import Chainweb.Pact5.Types +import qualified Data.Vector as V +import Data.Foldable +import Data.Either (partitionEithers) +import Control.Monad +import qualified Data.Text as T +import Control.Exception.Safe +import Control.Exception (evaluate) +import Control.DeepSeq + +-- | Calculate miner reward. We want this to error hard in the case where +-- block times have finally exceeded the 120-year range. Rewards are calculated +-- at regular blockheight intervals. +-- +-- See: 'rewards/miner_rewards.csv' +-- +minerReward + :: ChainwebVersion + -> MinerRewards + -> BlockHeight + -> IO Decimal +minerReward v (MinerRewards rs) bh = + case Map.lookupGE bh rs of + Nothing -> err + Just (_, m) -> pure $! roundTo 8 (m / n) + where + !n = int @Natural @Decimal . order $ chainGraphAt v bh + err = internalError "block heights have been exhausted" +{-# INLINE minerReward #-} + + +runPact5Coinbase + :: (Logger logger) + => Bool + -> Miner + -> PactBlockM logger Pact5Db tbl (Pact5.CommandResult [Pact5.TxLog ByteString] Void) +runPact5Coinbase True _ = return noCoinbase +runPact5Coinbase False miner = do + logger <- view (psServiceEnv . psLogger) + rs <- view (psServiceEnv . psMinerRewards) + v <- view chainwebVersion + txCtx <- TxContext <$> view psParentHeader <*> pure miner + + let !bh = ctxCurrentBlockHeight txCtx + + reward <- liftIO $! minerReward v rs bh + pactDb <- view (psBlockDbEnv . cpPactDbEnv) + + !cr <- liftIO $ Pact5.applyCoinbase logger pactDb reward txCtx + return cr + + where + upgradeInitCache newCache = do + liftPactServiceM $ logInfo "Updating init cache for upgrade" + updateInitCacheM newCache + +pact5TransactionsFromPayload + :: PayloadData + -> IO (Vector Pact5.Transaction) +pact5TransactionsFromPayload plData = do + vtrans <- fmap V.fromList $ + mapM toCWTransaction $ + toList (_payloadDataTransactions plData) + let (theLefts, theRights) = partitionEithers $ V.toList vtrans + unless (null theLefts) $ do + let ls = map T.pack theLefts + throwM $ TransactionDecodeFailure $ "Failed to decode pact transactions: " + <> T.intercalate ". " ls + return $! V.fromList theRights + where + toCWTransaction bs = evaluate (force (codecDecode Pact5.payloadCodec $ + _transactionBytes bs)) diff --git a/src/Chainweb/Pact/Service/BlockValidation.hs b/src/Chainweb/Pact/Service/BlockValidation.hs index 421fa9ad23..5e7853b2ab 100644 --- a/src/Chainweb/Pact/Service/BlockValidation.hs +++ b/src/Chainweb/Pact/Service/BlockValidation.hs @@ -46,18 +46,20 @@ import Chainweb.Pact.Service.Types import Chainweb.Payload import qualified Chainweb.Pact4.Transaction as Pact4 import Chainweb.Utils +import Chainweb.Version -newBlock :: Miner -> NewBlockFill -> ParentHeader -> PactQueue -> IO (Historical BlockInProgress) +newBlock :: Miner -> NewBlockFill -> ParentHeader -> PactQueue -> IO (Historical (ForSomePactVersion BlockInProgress)) newBlock mi fill parent reqQ = do - let !msg = NewBlockMsg NewBlockReq + let + !msg = NewBlockMsg NewBlockReq { _newBlockMiner = mi , _newBlockFill = fill , _newBlockParent = parent } submitRequestAndWait reqQ msg -continueBlock :: BlockInProgress -> PactQueue -> IO (Historical BlockInProgress) +continueBlock :: BlockInProgress pv -> PactQueue -> IO (Historical (BlockInProgress pv)) continueBlock bip reqQ = do let !msg = ContinueBlockMsg (ContinueBlockReq bip) submitRequestAndWait reqQ msg diff --git a/src/Chainweb/Pact/Service/Types.hs b/src/Chainweb/Pact/Service/Types.hs index cd22008d0d..2ff36ca43b 100644 --- a/src/Chainweb/Pact/Service/Types.hs +++ b/src/Chainweb/Pact/Service/Types.hs @@ -16,6 +16,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} -- | -- Module: Chainweb.Pact.Service.Types -- Copyright: Copyright © 2018 Kadena LLC. @@ -90,6 +95,7 @@ module Chainweb.Pact.Service.Types , toPayloadWithOutputs , toHashCommandResult , module Chainweb.Pact.Backend.Types + , ModuleCacheFor(..) ) where import Control.DeepSeq @@ -142,7 +148,7 @@ import Chainweb.Mempool.Mempool (InsertError(..),TransactionHash) import Chainweb.Miner.Pact import Chainweb.Pact.Backend.DbCache import Chainweb.Pact.Backend.Types -import Chainweb.Pact.NoCoinbase +import Chainweb.Pact4.NoCoinbase import Chainweb.Payload import Chainweb.Time import qualified Chainweb.Pact4.Transaction as Pact4 @@ -152,6 +158,9 @@ import Chainweb.Version.Mainnet import GHC.Stack import qualified Pact.Core.Errors as Pact5 import qualified Pact.Core.Command.Types as Pact5 +import Chainweb.Version (PactVersion) +import qualified Chainweb.Pact5.Transaction as Pact5 +import Data.ByteString (ByteString) -- | Value that represents a limitation for rewinding. newtype RewindLimit = RewindLimit { _rewindLimit :: Word64 } @@ -429,8 +438,8 @@ instance Show SubmittedRequestMsg where show (SubmittedRequestMsg msg _) = show msg data RequestMsg r where - ContinueBlockMsg :: !ContinueBlockReq -> RequestMsg (Historical BlockInProgress) - NewBlockMsg :: !NewBlockReq -> RequestMsg (Historical BlockInProgress) + ContinueBlockMsg :: !(ContinueBlockReq pv) -> RequestMsg (Historical (BlockInProgress pv)) + NewBlockMsg :: !NewBlockReq -> RequestMsg (Historical (ForSomePactVersion BlockInProgress)) ValidateBlockMsg :: !ValidateBlockReq -> RequestMsg PayloadWithOutputs LocalMsg :: !LocalReq -> RequestMsg LocalResult LookupPactTxsMsg :: !LookupPactTxsReq -> RequestMsg (HashMap PactHash (T2 BlockHeight BlockHash)) @@ -467,9 +476,13 @@ data NewBlockReq data NewBlockFill = NewBlockFill | NewBlockEmpty deriving stock Show -newtype ContinueBlockReq - = ContinueBlockReq BlockInProgress - deriving stock Show +data ContinueBlockReq pv + = ContinueBlockReq (BlockInProgress pv) +instance Show (ContinueBlockReq pv) where + showsPrec p (ContinueBlockReq bip) = + showParen (p > 10) $ + showString "ContinueBlockReq " . showsPrec 11 p . showString " " . + (case _blockInProgressPactVersion bip of {Pact4T -> showsPrec 11 bip; Pact5T -> showsPrec 11 bip}) data ValidateBlockReq = ValidateBlockReq { _valBlockHeader :: !BlockHeader @@ -593,20 +606,42 @@ cleanModuleCache v cid bh = ForkAtGenesis -> bh == genesisHeight v cid ForkNever -> False +data family ModuleCacheFor (pv :: PactVersion) +newtype instance ModuleCacheFor Pact4 + = Pact4ModuleCache ModuleCache + deriving newtype (Eq, Show, Monoid, Semigroup) +data instance ModuleCacheFor Pact5 + = Pact5NoModuleCache + deriving (Eq, Show) +instance Monoid (ModuleCacheFor Pact5) where + mempty = Pact5NoModuleCache +instance Semigroup (ModuleCacheFor Pact5) where + _ <> _ = Pact5NoModuleCache + +type family CommandResultFor (pv :: PactVersion) where + CommandResultFor Pact4 = CommandResult [TxLogJson] + CommandResultFor Pact5 = Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Info) + -- State from a block in progress, which is used to extend blocks after -- running their payloads. -data BlockInProgress = BlockInProgress +data BlockInProgress pv = BlockInProgress { _blockInProgressPendingData :: !SQLitePendingData , _blockInProgressTxId :: !TxId - , _blockInProgressModuleCache :: !ModuleCache + , _blockInProgressModuleCache :: !(ModuleCacheFor pv) , _blockInProgressParentHeader :: !ParentHeader , _blockInProgressRemainingGasLimit :: !GasLimit , _blockInProgressMiner :: !Miner - , _blockInProgressTransactions :: !(Transactions (CommandResult [TxLogJson])) - } deriving stock (Eq, Show) + , _blockInProgressTransactions :: !(Transactions pv (CommandResultFor pv)) + , _blockInProgressPactVersion :: !(PactVersionT pv) + } +deriving stock instance Eq (BlockInProgress Pact4) +deriving stock instance Eq (BlockInProgress Pact5) +deriving stock instance Show (BlockInProgress Pact4) +deriving stock instance Show (BlockInProgress Pact5) + -- This block is not really valid, don't use it outside tests. -emptyBlockInProgressForTesting :: BlockInProgress +emptyBlockInProgressForTesting :: BlockInProgress Pact4 emptyBlockInProgressForTesting = BlockInProgress { _blockInProgressPendingData = emptySQLitePendingData , _blockInProgressTxId = TxId 0 @@ -619,15 +654,20 @@ emptyBlockInProgressForTesting = BlockInProgress { _transactionCoinbase = noCoinbase , _transactionPairs = mempty } + , _blockInProgressPactVersion = Pact4T } -blockInProgressToPayloadWithOutputs :: BlockInProgress -> PayloadWithOutputs -blockInProgressToPayloadWithOutputs bip = toPayloadWithOutputs - (_blockInProgressMiner bip) - (_blockInProgressTransactions bip) - -toPayloadWithOutputs :: Miner -> Transactions (CommandResult [TxLogJson]) -> PayloadWithOutputs -toPayloadWithOutputs mi ts = +blockInProgressToPayloadWithOutputs :: BlockInProgress pv -> PayloadWithOutputs +blockInProgressToPayloadWithOutputs bip = case _blockInProgressPactVersion bip of + Pact4T -> toPayloadWithOutputs + Pact4T + (_blockInProgressMiner bip) + (_blockInProgressTransactions bip) + -- TODO + Pact5T -> error "pact5" + +toPayloadWithOutputs :: PactVersionT pv -> Miner -> Transactions pv (CommandResult [TxLogJson]) -> PayloadWithOutputs +toPayloadWithOutputs Pact4T mi ts = let oldSeq = _transactionPairs ts trans = cmdBSToTx . fst <$> oldSeq transOuts = toOutputBytes . toHashCommandResult . snd <$> oldSeq @@ -642,6 +682,7 @@ toPayloadWithOutputs mi ts = blockPL = blockPayload blockTrans blockOuts plData = payloadData blockTrans blockPL in payloadWithOutputs plData cb transOuts +toPayloadWithOutputs Pact5T mi ts = error "pact5" toTransactionBytes :: Command Text -> Transaction toTransactionBytes cwTrans = @@ -656,11 +697,26 @@ toOutputBytes cr = toHashCommandResult :: CommandResult [TxLogJson] -> CommandResult Hash toHashCommandResult = over (crLogs . _Just) $ pactHash . encodeTxLogJsonArray -data Transactions r = Transactions - { _transactionPairs :: !(Vector (Pact4.Transaction, r)) - , _transactionCoinbase :: !(CommandResult [TxLogJson]) +type family TransactionFor (pv :: PactVersion) where + TransactionFor Pact4 = Pact4.Transaction + TransactionFor Pact5 = Pact5.Transaction + +data Transactions (pv :: PactVersion) r = Transactions + { _transactionPairs :: !(Vector (TransactionFor pv, r)) + , _transactionCoinbase :: !(CommandResultFor pv) } - deriving stock (Functor, Foldable, Traversable, Eq, Show, Generic) - deriving anyclass NFData + deriving stock (Functor, Foldable, Traversable, Generic) +deriving stock instance Eq r => Eq (Transactions Pact4 r) +deriving stock instance Eq r => Eq (Transactions Pact5 r) +deriving stock instance Show r => Show (Transactions Pact4 r) +deriving stock instance Show r => Show (Transactions Pact5 r) +deriving anyclass instance NFData r => NFData (Transactions Pact4 r) +-- why doesn't this compile? +-- deriving anyclass instance NFData r => NFData (Transactions Pact5 r) +instance NFData r => NFData (Transactions Pact5 r) where + rnf txs = + rnf (_transactionPairs txs) + `seq` rnf (_transactionCoinbase) + makeLenses 'Transactions makeLenses 'BlockInProgress diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index 7ef3048168..314f25cfd5 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -16,6 +16,9 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module: Chainweb.Pact.Types -- Copyright: Copyright © 2018 Kadena LLC. @@ -86,6 +89,9 @@ module Chainweb.Pact.Types , psParentHeader , psServiceEnv , runPactBlockM + , dispatchBlockOnPactVersion + , assertBlockPact4 + , assertBlockPact5 -- * Logging with Pact logger @@ -191,6 +197,7 @@ import Utils.Logging.Trace import Data.Decimal (Decimal) import qualified Pact.Core.StableEncoding as Pact5 import qualified Pact.Core.Literal as Pact5 +import Chainweb.Version.Guards (pact5) -- -------------------------------------------------------------------------- -- -- Coinbase output utils @@ -358,7 +365,7 @@ type ModuleInitCache = M.Map BlockHeight ModuleCache data PactBlockEnv logger db tbl = PactBlockEnv { _psServiceEnv :: !(PactServiceEnv logger tbl) , _psParentHeader :: !ParentHeader - , _psBlockDbEnv :: !db + , _psBlockDbEnv :: !(CurrentBlockDbEnv logger db) } data PactServiceState = PactServiceState @@ -480,6 +487,35 @@ newtype PactBlockM logger db tbl a = PactBlockM , MonadIO ) +type instance Magnified (PactBlockM logger db tbl) = Magnified (ReaderT (PactBlockEnv logger db tbl) (StateT PactServiceState IO)) +instance Magnify + (PactBlockM logger db tbl) (PactBlockM logger db' tbl) + (PactBlockEnv logger db tbl) (PactBlockEnv logger db' tbl) where + magnify l (PactBlockM p) = PactBlockM (magnify l p) + +dispatchBlockOnPactVersion + :: ChainwebVersion + -> ChainId + -> BlockHeight + -> PactBlockM logger (Pact4Db logger) tbl a + -> PactBlockM logger Pact5Db tbl a + -> PactBlockM logger (DynamicPactDb logger) tbl a +dispatchBlockOnPactVersion v cid bh ifPact4 ifPact5 + | pact5 v cid bh = assertBlockPact4 ifPact4 + | otherwise = assertBlockPact5 ifPact5 + +assertBlockPact4 :: PactBlockM logger (Pact4Db logger) tbl a -> PactBlockM logger (DynamicPactDb logger) tbl a +assertBlockPact4 act = do + env <- ask + env' <- env & traverseOf (psBlockDbEnv . cpPactDbEnv) assertDynamicPact4Db + magnify (to (\_ -> env')) act + +assertBlockPact5 :: PactBlockM logger Pact5Db tbl a -> PactBlockM logger (DynamicPactDb logger) tbl a +assertBlockPact5 act = do + env <- ask + env' <- env & traverseOf (psBlockDbEnv . cpPactDbEnv) assertDynamicPact5Db + magnify (to (\_ -> env')) act + -- | Lifts PactServiceM to PactBlockM by forgetting about the current block. -- It is unsafe to use `runPactBlockM` inside the argument to this function. liftPactServiceM :: PactServiceM logger tbl a -> PactBlockM logger db tbl a @@ -524,7 +560,7 @@ updateInitCacheM mc = do -- a database snapshot at that block and information about the parent header. -- It is unsafe to use this function in an argument to `liftPactServiceM`. runPactBlockM - :: ParentHeader -> db + :: ParentHeader -> CurrentBlockDbEnv logger db -> PactBlockM logger db tbl a -> PactServiceM logger tbl a runPactBlockM pctx dbEnv (PactBlockM r) = PactServiceM $ ReaderT $ \e -> StateT $ \s -> runStateT (runReaderT r (PactBlockEnv e pctx dbEnv)) s diff --git a/src/Chainweb/Pact/NoCoinbase.hs b/src/Chainweb/Pact4/NoCoinbase.hs similarity index 90% rename from src/Chainweb/Pact/NoCoinbase.hs rename to src/Chainweb/Pact4/NoCoinbase.hs index 790bfbed6f..5994f6335a 100644 --- a/src/Chainweb/Pact/NoCoinbase.hs +++ b/src/Chainweb/Pact4/NoCoinbase.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | --- Module: Chainweb.Pact.NoCoinbase +-- Module: Chainweb.Pact4.NoCoinbase -- Copyright: Copyright © 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -10,7 +10,7 @@ -- -- A noop coin base for genesis transactions and testing purposes. -- -module Chainweb.Pact.NoCoinbase +module Chainweb.Pact4.NoCoinbase ( noCoinbase ) where diff --git a/src/Chainweb/Pact4/TransactionExec.hs b/src/Chainweb/Pact4/TransactionExec.hs index c9757ffbaa..a680e288ae 100644 --- a/src/Chainweb/Pact4/TransactionExec.hs +++ b/src/Chainweb/Pact4/TransactionExec.hs @@ -701,10 +701,10 @@ applyLocal logger gasLogger dbEnv gasModel txCtx spv cmdIn mc execConfig = readInitModules :: forall logger tbl. (Logger logger) - => PactBlockM logger tbl ModuleCache + => PactBlockM logger (Pact4Db logger) tbl ModuleCache readInitModules = do logger <- view (psServiceEnv . psLogger) - dbEnv <- liftIO . assertDynamicPact4Db . _cpPactDbEnv =<< view psBlockDbEnv + dbEnv <- view (psBlockDbEnv . to _cpPactDbEnv) txCtx <- getTxContext noMiner def -- guarding chainweb 2.17 here to allow for @@ -798,8 +798,8 @@ applyUpgrades -> BlockHeight -> TransactionM logger p (Maybe ModuleCache) applyUpgrades v cid height - | Just upg <- - v ^? versionPact4Upgrades . onChain cid . at height . _Just = applyUpgrade upg + | Just (ForPact4 upg) <- + v ^? versionUpgrades . onChain cid . at height . _Just = applyUpgrade upg | cleanModuleCache v cid height = filterModuleCache | otherwise = return Nothing where diff --git a/src/Chainweb/Pact5/NoCoinbase.hs b/src/Chainweb/Pact5/NoCoinbase.hs new file mode 100644 index 0000000000..62e47813f1 --- /dev/null +++ b/src/Chainweb/Pact5/NoCoinbase.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: Chainweb.Pact5.NoCoinbase +-- Copyright: Copyright © 2020 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- A noop coin base for genesis transactions and testing purposes. +-- +module Chainweb.Pact5.NoCoinbase +( noCoinbase +) where + +import Data.Void +import Pact.Core.Command.Types +import Pact.Core.Gas +import Pact.Core.Hash +import Pact.Core.PactValue + +-- | No-op coinbase payload +-- +noCoinbase :: CommandResult a Void +noCoinbase = CommandResult + (RequestKey pactInitialHash) Nothing + (PactResultOk (PString "NO_COINBASE")) + (Gas 0) Nothing Nothing Nothing [] +{-# NOINLINE noCoinbase #-} diff --git a/src/Chainweb/Pact5/TransactionExec.hs b/src/Chainweb/Pact5/TransactionExec.hs index 9da3664190..110aefa6f8 100644 --- a/src/Chainweb/Pact5/TransactionExec.hs +++ b/src/Chainweb/Pact5/TransactionExec.hs @@ -14,6 +14,7 @@ {-# OPTIONS_GHC -Wno-partial-type-signatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Chainweb.Pact.TransactionExec -- Copyright : Copyright © 2018 Kadena LLC. @@ -278,7 +279,7 @@ applyLocal -- ^ Pact logger -> Maybe logger -- ^ Pact gas logger - -> CoreDb + -> Pact5Db -- ^ Pact db environment -> TxContext -- ^ tx metadata and parent header @@ -348,12 +349,11 @@ applyLocal logger maybeGasLogger coreDb txCtx spvSupport cmd = do -- applyCmd :: (Logger logger) - => ChainwebVersion - -> logger + => logger -- ^ Pact logger -> Maybe logger -- ^ Pact gas logger - -> CoreDb + -> Pact5Db -- ^ Pact db environment -> TxContext -- ^ tx metadata @@ -364,7 +364,7 @@ applyCmd -> Gas -- ^ initial gas used -> IO (CommandResult [TxLog ByteString] TxFailedError) -applyCmd v logger maybeGasLogger coreDb txCtx spv cmd initialGas = do +applyCmd logger maybeGasLogger pact5Db txCtx spv cmd initialGas = do let !requestKey = cmdToRequestKey cmd -- this process is "paid for", i.e. it's powered by a supply of gas that was -- purchased by a user already. any errors here will result in the entire gas @@ -379,14 +379,14 @@ applyCmd v logger maybeGasLogger coreDb txCtx spv cmd initialGas = do runVerifiers txCtx cmd -- run payload - runPayload Transactional coreDb spv txCtx cmd + runPayload Transactional pact5Db spv txCtx cmd when (GasLimit initialGas > gasLimit) $ throwM $ BuyGasFailure $ Pact5GasPurchaseFailure requestKey "tx too big for gas limit" - catchesPact5Error logger (buyGas logger coreDb txCtx cmd) >>= \case + fmap join (catchesPact5Error logger (buyGas logger pact5Db txCtx cmd)) >>= \case Left e -> - throwM $ BuyGasFailure $ Pact5GasPurchaseFailure requestKey (sshow e) + throwM $ BuyGasFailure $ Pact5GasPurchaseFailure requestKey (T.pack $ displayException e) Right buyGasResult -> do gasRef <- newIORef (MilliGas 0) gasLogRef <- forM maybeGasLogger $ \_ -> @@ -406,7 +406,7 @@ applyCmd v logger maybeGasLogger coreDb txCtx spv cmd initialGas = do -- and all of the gas is sent to the miner. -- only buying gas and sending it to the miner are recorded. redeemGasResult <- redeemGas - logger coreDb txCtx + logger pact5Db txCtx (gasLimit ^. _GasLimit) (_peDefPactId <$> _erExec buyGasResult) cmd @@ -427,7 +427,7 @@ applyCmd v logger maybeGasLogger coreDb txCtx spv cmd initialGas = do -- immediately return all unused gas to the user and send all used -- gas to the miner. redeemGasResult <- redeemGas - logger coreDb txCtx + logger pact5Db txCtx gasUsed (_peDefPactId <$> _erExec buyGasResult) cmd @@ -446,6 +446,7 @@ applyCmd v logger maybeGasLogger coreDb txCtx spv cmd initialGas = do } where + v = _chainwebVersion txCtx !gasLimit = view (cmdPayload . pMeta . pmGasLimit) cmd -- | Convert context to datatype for Pact environment using the @@ -470,28 +471,27 @@ ctxToPublicData pm (TxContext ph _) = PublicData -- a transaction which pays miners their block reward. applyCoinbase :: (Logger logger) - => ChainwebVersion - -> logger + => logger -- ^ Pact logger - -> CoreDb + -> Pact5Db -- ^ Pact db environment -> Decimal -- ^ Miner reward -> TxContext -- ^ tx metadata and parent header -> IO (CommandResult [TxLog ByteString] Void) -applyCoinbase v logger coreDb reward txCtx = do +applyCoinbase logger pact5Db reward txCtx = do -- for some reason this is the base64-encoded hash, rather than the binary hash let coinbaseHash = Hash $ SB.toShort $ T.encodeUtf8 $ blockHashToText parentBlockHash -- applyCoinbase is when upgrades happen, so we call applyUpgrades first - applyUpgrades logger coreDb txCtx + applyUpgrades logger pact5Db txCtx -- we construct the coinbase term and evaluate it let (coinbaseTerm, coinbaseData) = mkCoinbaseTerm mid mks reward coinbaseTxResult <- either (throwM . CoinbaseFailure . sshow) return . join =<< catchesPact5Error logger (evalExec Transactional - coreDb noSPVSupport freeGasModel (Set.fromList [FlagDisableRuntimeRTC]) managedNamespacePolicy + pact5Db noSPVSupport freeGasModel (Set.fromList [FlagDisableRuntimeRTC]) managedNamespacePolicy (ctxToPublicData def txCtx) MsgData { mdHash = coinbaseHash @@ -533,19 +533,19 @@ applyCoinbase v logger coreDb reward txCtx = do applyUpgrades :: (Logger logger) => logger - -> CoreDb + -> Pact5Db -> TxContext -> IO () applyUpgrades logger db txCtx - | Just upg <- _chainwebVersion txCtx - ^? versionPact5Upgrades + | Just (ForPact5 upg) <- _chainwebVersion txCtx + ^? versionUpgrades . onChain (_chainId txCtx) . at (ctxCurrentBlockHeight txCtx) . _Just = applyUpgrade upg | otherwise = return () where - applyUpgrade :: Pact5Upgrade -> IO () + applyUpgrade :: PactUpgrade Pact5 -> IO () applyUpgrade upg = do let payloads = map (fmap _payloadObj) $ _pact5UpgradeTransactions upg forM_ (_pact5UpgradeTransactions upg) $ \tx -> @@ -573,12 +573,12 @@ runPayload :: forall logger err . (Logger logger) => ExecutionMode - -> CoreDb + -> Pact5Db -> SPVSupport -> TxContext -> Command (Payload PublicMeta ParsedCode) -> TransactionM logger EvalResult -runPayload execMode coreDb spv txCtx cmd = do +runPayload execMode pact5Db spv txCtx cmd = do -- Note [Throw out verifier proofs eagerly] let !verifiersWithNoProof = @@ -589,7 +589,7 @@ runPayload execMode coreDb spv txCtx cmd = do Exec ExecMsg {..} -> do either (throwError . TxPactError) return =<< catchUnknownExceptions (evalExec execMode - coreDb spv gm (Set.fromList [FlagDisableRuntimeRTC]) managedNamespacePolicy + pact5Db spv gm (Set.fromList [FlagDisableRuntimeRTC]) managedNamespacePolicy (ctxToPublicData publicMeta txCtx) MsgData { mdHash = _cmdHash cmd @@ -604,7 +604,7 @@ runPayload execMode coreDb spv txCtx cmd = do Continuation ContMsg {..} -> do either (throwError . TxPactError) return =<< catchUnknownExceptions (evalContinuation execMode - coreDb spv gm (Set.fromList [FlagDisableRuntimeRTC]) managedNamespacePolicy + pact5Db spv gm (Set.fromList [FlagDisableRuntimeRTC]) managedNamespacePolicy (ctxToPublicData publicMeta txCtx) MsgData { mdHash = _cmdHash cmd @@ -641,14 +641,14 @@ runPayload execMode coreDb spv txCtx cmd = do runUpgrade :: (Logger logger) => logger - -> CoreDb + -> Pact5Db -> TxContext -> Command (Payload PublicMeta ParsedCode) -> IO () -runUpgrade logger coreDb txContext cmd = case payload of +runUpgrade logger pact5Db txContext cmd = case payload of Exec pm -> evalExec Transactional - coreDb noSPVSupport freeGasModel (Set.fromList [FlagDisableRuntimeRTC]) SimpleNamespacePolicy + pact5Db noSPVSupport freeGasModel (Set.fromList [FlagDisableRuntimeRTC]) SimpleNamespacePolicy (ctxToPublicData publicMeta txContext) MsgData { mdHash = chash @@ -678,7 +678,7 @@ buyGas :: (Logger logger) => logger -> PactDb CoreBuiltin Info -> TxContext - -> Command (Payload PublicMeta a) -> IO EvalResult + -> Command (Payload PublicMeta a) -> IO (Either (PactError Info) EvalResult) buyGas logger db txCtx cmd = do -- TODO: use quirked gas? let @@ -717,7 +717,7 @@ buyGas logger db txCtx cmd = do case _erExec er' of Nothing | isChainweb224Pact -> - return er' + return $ Right er' | otherwise -> -- should never occur pre-chainweb 2.24: -- would mean coin.fund-tx is not a pact @@ -726,9 +726,9 @@ buyGas logger db txCtx cmd = do | isChainweb224Pact -> internalError "buyGas: Internal error - continuation found after 2.24 fork" | otherwise -> - return er' + return $ Right er' Left err -> do - internalError $ "buyGas: Internal error - " <> sshow err + return $ Left err where isChainweb224Pact = guardCtx chainweb224Pact txCtx publicMeta = cmd ^. cmdPayload . pMeta diff --git a/src/Chainweb/Pact5/Types.hs b/src/Chainweb/Pact5/Types.hs index c3499e987a..e562dd80af 100644 --- a/src/Chainweb/Pact5/Types.hs +++ b/src/Chainweb/Pact5/Types.hs @@ -69,5 +69,5 @@ guardCtx :: (ChainwebVersion -> Chainweb.ChainId.ChainId -> BlockHeight -> a) -> guardCtx g txCtx = g (ctxVersion txCtx) (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) -- | Assemble tx context from transaction metadata and parent header. -getTxContext :: Miner -> PactBlockM logger tbl TxContext +getTxContext :: Miner -> PactBlockM logger db tbl TxContext getTxContext miner = view psParentHeader >>= \ph -> return (TxContext ph miner) diff --git a/src/Chainweb/Rosetta/Internal.hs b/src/Chainweb/Rosetta/Internal.hs index 1e4aa08add..807e8f30e7 100644 --- a/src/Chainweb/Rosetta/Internal.hs +++ b/src/Chainweb/Rosetta/Internal.hs @@ -123,7 +123,7 @@ matchLogs -> ExceptT RosettaFailure Handler tx matchLogs typ bh logs coinbase txs | bheight == genesisHeight v cid = matchGenesis - | Just upg <- v ^? versionPact4Upgrades . onChain cid . at bheight . _Just = matchRemediation upg + | Just (ForPact4 upg) <- v ^? versionUpgrades . onChain cid . at bheight . _Just = matchRemediation upg -- TODO: integrate pact 5? | otherwise = matchRest where diff --git a/src/Chainweb/Version.hs b/src/Chainweb/Version.hs index b040a77930..8f22b32a57 100644 --- a/src/Chainweb/Version.hs +++ b/src/Chainweb/Version.hs @@ -16,6 +16,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module: Chainweb.Version @@ -48,8 +50,6 @@ module Chainweb.Version , decodeChainwebVersionCode , ChainwebVersionName(..) , ChainwebVersion(..) - , Pact4Upgrade(..) - , Pact5Upgrade(..) , pact4Upgrade , VersionQuirks(..) , noQuirks @@ -58,8 +58,7 @@ module Chainweb.Version , versionBlockDelay , versionCheats , versionDefaults - , versionPact4Upgrades - , versionPact5Upgrades + , versionUpgrades , versionBootstraps , versionCode , versionGraphs @@ -76,6 +75,13 @@ module Chainweb.Version , genesisBlockTarget , genesisTime + , PactUpgrade(..) + , PactVersion(..) + , PactVersionT(..) + , ForBothPactVersions(..) + , ForSomePactVersion(..) + , forAnyPactVersion + -- * Typelevel ChainwebVersionName , ChainwebVersionT(..) , ChainwebVersionSymbol @@ -174,6 +180,7 @@ import Pact.Types.Verifier import Data.Singletons import P2P.Peer +import Data.Kind (Type) -- | Data type representing changes to block validation, whether in the payload -- or in the header. Always add new forks at the end, not in the middle of the @@ -211,7 +218,7 @@ data Fork | Chainweb223Pact | Chainweb224Pact | Chainweb225Pact - | Pact5 + | Pact5Fork -- always add new forks at the end, not in the middle of the constructors. deriving stock (Bounded, Generic, Eq, Enum, Ord, Show) deriving anyclass (NFData, Hashable) @@ -247,7 +254,7 @@ instance HasTextRepresentation Fork where toText Chainweb223Pact = "chainweb223Pact" toText Chainweb224Pact = "chainweb224Pact" toText Chainweb225Pact = "chainweb225Pact" - toText Pact5 = "Pact5" + toText Pact5Fork = "Pact5" fromText "slowEpoch" = return SlowEpoch fromText "vuln797Fix" = return Vuln797Fix @@ -279,7 +286,7 @@ instance HasTextRepresentation Fork where fromText "chainweb223Pact" = return Chainweb223Pact fromText "chainweb224Pact" = return Chainweb224Pact fromText "chainweb225Pact" = return Chainweb225Pact - fromText "pact5" = return Pact5 + fromText "pact5" = return Pact5Fork fromText t = throwM . TextFormatException $ "Unknown Chainweb fork: " <> t instance ToJSON Fork where @@ -322,10 +329,33 @@ instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ChainwebVer toMerkleNode = encodeMerkleInputNode encodeChainwebVersionCode fromMerkleNode = decodeMerkleInputNode decodeChainwebVersionCode +data PactVersion = Pact4 | Pact5 +data PactVersionT (v :: PactVersion) where + Pact4T :: PactVersionT Pact4 + Pact5T :: PactVersionT Pact5 +deriving stock instance Eq (PactVersionT v) +deriving stock instance Show (PactVersionT v) +data ForSomePactVersion f = ForPact4 (f Pact4) | ForPact5 (f Pact5) +forAnyPactVersion :: (forall pv. f pv -> a) -> ForSomePactVersion f -> a +forAnyPactVersion k (ForPact4 f) = k f +forAnyPactVersion k (ForPact5 f) = k f +data ForBothPactVersions f = ForBothPactVersions + { _forPact4 :: (f Pact4), _forPact5 :: (f Pact5) } +deriving stock instance (Eq (f Pact4), Eq (f Pact5)) => Eq (ForBothPactVersions f) +deriving stock instance (Show (f Pact4), Show (f Pact5)) => Show (ForBothPactVersions f) +deriving stock instance (Eq (f Pact4), Eq (f Pact5)) => Eq (ForSomePactVersion f) +deriving stock instance (Show (f Pact4), Show (f Pact5)) => Show (ForSomePactVersion f) +instance (NFData (f Pact4), NFData (f Pact5)) => NFData (ForBothPactVersions f) where + rnf b = rnf (_forPact4 b) `seq` rnf (_forPact5 b) +instance (NFData (f Pact4), NFData (f Pact5)) => NFData (ForSomePactVersion f) where + rnf (ForPact4 f) = rnf f + rnf (ForPact5 f) = rnf f + -- The type of upgrades, which are sets of transactions to run at certain block -- heights during coinbase. -- -data Pact4Upgrade = Pact4Upgrade +data family PactUpgrade (v :: PactVersion) :: Type +data instance PactUpgrade Pact4 = Pact4Upgrade { _pact4UpgradeTransactions :: [Pact4.Transaction] , _legacyUpgradeIsPrecocious :: Bool -- ^ when set to `True`, the upgrade transactions are executed using the @@ -335,23 +365,19 @@ data Pact4Upgrade = Pact4Upgrade } deriving stock (Generic, Eq) deriving anyclass (NFData) - --- The type of upgrades, which are sets of transactions to run at certain block --- heights during coinbase. --- -data Pact5Upgrade = Pact5Upgrade +data instance PactUpgrade Pact5 = Pact5Upgrade { _pact5UpgradeTransactions :: [Pact5.Transaction] } deriving stock (Generic, Eq) deriving anyclass (NFData) -instance Show Pact4Upgrade where +instance Show (PactUpgrade Pact4) where show _ = "" -instance Show Pact5Upgrade where +instance Show (PactUpgrade Pact5) where show _ = "" -pact4Upgrade :: [Pact4.Transaction] -> Pact4Upgrade +pact4Upgrade :: [Pact4.Transaction] -> PactUpgrade Pact4 pact4Upgrade txs = Pact4Upgrade txs False -- The type of quirks, i.e. special validation behaviors that are in some @@ -398,11 +424,8 @@ data ChainwebVersion -- ^ The block heights on each chain to apply behavioral changes. -- Interpretation of these is up to the functions in -- `Chainweb.Version.Guards`. - , _versionPact4Upgrades :: ChainMap (HashMap BlockHeight Pact4Upgrade) - -- ^ The Pact 4 upgrade transactions to execute on each chain at certain block - -- heights. - , _versionPact5Upgrades :: ChainMap (HashMap BlockHeight Pact5Upgrade) - -- ^ The Pact 5 upgrade transactions to execute on each chain at certain block + , _versionUpgrades :: ChainMap (HashMap BlockHeight (ForSomePactVersion PactUpgrade)) + -- ^ The Pact upgrade transactions to execute on each chain at certain block -- heights. , _versionBlockDelay :: BlockDelay -- ^ The Proof-of-Work `BlockDelay` for each `ChainwebVersion`. This is @@ -461,8 +484,7 @@ instance Ord ChainwebVersion where instance Eq ChainwebVersion where v == v' = and [ compare v v' == EQ - , _versionPact4Upgrades v == _versionPact4Upgrades v' - , _versionPact5Upgrades v == _versionPact5Upgrades v' + , _versionUpgrades v == _versionUpgrades v' , _versionGenesis v == _versionGenesis v' ] @@ -646,7 +668,6 @@ latestBehaviorAt v = foldlOf' behaviorChanges max 0 v + 1 where behaviorChanges = fold [ versionForks . folded . folded . _ForkAtBlockHeight - , versionPact4Upgrades . folded . ifolded . asIndex - , versionPact5Upgrades . folded . ifolded . asIndex + , versionUpgrades . folded . ifolded . asIndex , versionGraphs . to ruleHead . _1 . _Just ] diff --git a/src/Chainweb/Version/Development.hs b/src/Chainweb/Version/Development.hs index 2848ce3932..aec4736721 100644 --- a/src/Chainweb/Version/Development.hs +++ b/src/Chainweb/Version/Development.hs @@ -32,8 +32,7 @@ devnet = ChainwebVersion { _versionCode = ChainwebVersionCode 0x00000002 , _versionName = ChainwebVersionName "development" , _versionForks = tabulateHashMap $ \_ -> AllChains ForkAtGenesis - , _versionPact4Upgrades = AllChains mempty - , _versionPact5Upgrades = AllChains mempty + , _versionUpgrades = AllChains mempty , _versionGraphs = End twentyChainGraph , _versionBlockDelay = BlockDelay 30_000_000 , _versionWindow = WindowWidth 120 diff --git a/src/Chainweb/Version/Guards.hs b/src/Chainweb/Version/Guards.hs index 9a7403eae0..a4a10a00f3 100644 --- a/src/Chainweb/Version/Guards.hs +++ b/src/Chainweb/Version/Guards.hs @@ -220,7 +220,7 @@ pact42 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool pact42 = checkFork atOrAfter Pact42 pact5 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool -pact5 = checkFork atOrAfter Pact5 +pact5 = checkFork atOrAfter Pact5Fork chainweb213Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool chainweb213Pact = checkFork atOrAfter Chainweb213Pact diff --git a/src/Chainweb/Version/Mainnet.hs b/src/Chainweb/Version/Mainnet.hs index f7b5b24501..b85ca705d1 100644 --- a/src/Chainweb/Version/Mainnet.hs +++ b/src/Chainweb/Version/Mainnet.hs @@ -135,7 +135,7 @@ mainnet = ChainwebVersion Pact4Coin3 -> AllChains (ForkAtBlockHeight $ BlockHeight 1_722_500) -- 2021-06-19T03:34:05+00:00 EnforceKeysetFormats -> AllChains (ForkAtBlockHeight $ BlockHeight 2_162_000) -- 2022-01-17T17:51:12 Pact42 -> AllChains (ForkAtBlockHeight $ BlockHeight 2_334_500) -- 2022-01-17T17:51:12+00:00 - Pact5 -> AllChains ForkNever + Pact5Fork -> AllChains ForkNever CheckTxHash -> AllChains (ForkAtBlockHeight $ BlockHeight 2_349_800) -- 2022-01-23T02:53:38 Chainweb213Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 2_447_315) -- 2022-02-26T00:00:00+00:00 Chainweb214Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 2_605_663) -- 2022-04-22T00:00:00+00:00 @@ -183,27 +183,26 @@ mainnet = ChainwebVersion , [(unsafeChainId i, MNKAD.payloadBlock) | i <- [10..19]] ] } - , _versionPact4Upgrades = chainZip HM.union + , _versionUpgrades = chainZip HM.union (indexByForkHeights mainnet [ (CoinV2, onChains - [ (unsafeChainId 0, pact4Upgrade MN0.transactions) - , (unsafeChainId 1, pact4Upgrade MN1.transactions) - , (unsafeChainId 2, pact4Upgrade MN2.transactions) - , (unsafeChainId 3, pact4Upgrade MN3.transactions) - , (unsafeChainId 4, pact4Upgrade MN4.transactions) - , (unsafeChainId 5, pact4Upgrade MN5.transactions) - , (unsafeChainId 6, pact4Upgrade MN6.transactions) - , (unsafeChainId 7, pact4Upgrade MN7.transactions) - , (unsafeChainId 8, pact4Upgrade MN8.transactions) - , (unsafeChainId 9, pact4Upgrade MN9.transactions) + [ (unsafeChainId 0, ForPact4 $ pact4Upgrade MN0.transactions) + , (unsafeChainId 1, ForPact4 $ pact4Upgrade MN1.transactions) + , (unsafeChainId 2, ForPact4 $ pact4Upgrade MN2.transactions) + , (unsafeChainId 3, ForPact4 $ pact4Upgrade MN3.transactions) + , (unsafeChainId 4, ForPact4 $ pact4Upgrade MN4.transactions) + , (unsafeChainId 5, ForPact4 $ pact4Upgrade MN5.transactions) + , (unsafeChainId 6, ForPact4 $ pact4Upgrade MN6.transactions) + , (unsafeChainId 7, ForPact4 $ pact4Upgrade MN7.transactions) + , (unsafeChainId 8, ForPact4 $ pact4Upgrade MN8.transactions) + , (unsafeChainId 9, ForPact4 $ pact4Upgrade MN9.transactions) ]) - , (Pact4Coin3, AllChains $ Pact4Upgrade CoinV3.transactions True) - , (Chainweb214Pact, AllChains $ Pact4Upgrade CoinV4.transactions True) - , (Chainweb215Pact, AllChains $ Pact4Upgrade CoinV5.transactions True) - , (Chainweb223Pact, AllChains $ pact4Upgrade CoinV6.transactions) + , (Pact4Coin3, AllChains $ ForPact4 $ Pact4Upgrade CoinV3.transactions True) + , (Chainweb214Pact, AllChains $ ForPact4 $ Pact4Upgrade CoinV4.transactions True) + , (Chainweb215Pact, AllChains $ ForPact4 $ Pact4Upgrade CoinV5.transactions True) + , (Chainweb223Pact, AllChains $ ForPact4 $ pact4Upgrade CoinV6.transactions) ]) - (onChains [(unsafeChainId 0, HM.singleton to20ChainsMainnet (pact4Upgrade MNKAD.transactions))]) - , _versionPact5Upgrades = AllChains mempty + (onChains [(unsafeChainId 0, HM.singleton to20ChainsMainnet (ForPact4 $ pact4Upgrade MNKAD.transactions))]) , _versionCheats = VersionCheats { _disablePow = False , _fakeFirstEpochStart = False diff --git a/src/Chainweb/Version/RecapDevelopment.hs b/src/Chainweb/Version/RecapDevelopment.hs index b7aa735adc..3892ed51a4 100644 --- a/src/Chainweb/Version/RecapDevelopment.hs +++ b/src/Chainweb/Version/RecapDevelopment.hs @@ -59,7 +59,6 @@ recapDevnet = ChainwebVersion Pact4Coin3 -> AllChains $ ForkAtBlockHeight $ BlockHeight 80 EnforceKeysetFormats -> AllChains $ ForkAtBlockHeight $ BlockHeight 100 Pact42 -> AllChains $ ForkAtBlockHeight $ BlockHeight 90 - Pact5 -> AllChains ForkNever CheckTxHash -> AllChains $ ForkAtBlockHeight $ BlockHeight 110 Chainweb213Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 95 Chainweb214Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 115 @@ -75,17 +74,17 @@ recapDevnet = ChainwebVersion Chainweb223Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 600 Chainweb224Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 610 Chainweb225Pact -> AllChains ForkNever + Pact5Fork -> AllChains ForkNever - , _versionPact4Upgrades = foldr (chainZip HM.union) (AllChains mempty) + , _versionUpgrades = foldr (chainZip HM.union) (AllChains mempty) [ indexByForkHeights recapDevnet - [ (CoinV2, onChains [(unsafeChainId i, pact4Upgrade RecapDevnet.transactions) | i <- [0..9]]) - , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) + [ (CoinV2, onChains [(unsafeChainId i, ForPact4 $ pact4Upgrade RecapDevnet.transactions) | i <- [0..9]]) + , (Pact4Coin3, AllChains (ForPact4 $ Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, AllChains (ForPact4 $ Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, AllChains (ForPact4 $ Pact4Upgrade CoinV5.transactions True)) ] - , onChains [(unsafeChainId 0, HM.singleton to20ChainsHeight (pact4Upgrade MNKAD.transactions))] + , onChains [(unsafeChainId 0, HM.singleton to20ChainsHeight (ForPact4 $ pact4Upgrade MNKAD.transactions))] ] - , _versionPact5Upgrades = AllChains mempty , _versionGraphs = (to20ChainsHeight, twentyChainGraph) `Above` diff --git a/src/Chainweb/Version/Registry.hs b/src/Chainweb/Version/Registry.hs index 5d90a8e409..2ddec4a94a 100644 --- a/src/Chainweb/Version/Registry.hs +++ b/src/Chainweb/Version/Registry.hs @@ -96,14 +96,15 @@ validateVersion v = do , hasAllChains (_genesisBlockTarget $ _versionGenesis v) , hasAllChains (_genesisTime $ _versionGenesis v) ])] - , [ "validateVersion: some pact 4 upgrade has no transactions" - | any (any (\upg -> null (_pact4UpgradeTransactions upg))) (_versionPact4Upgrades v) ] - , [ "validateVersion: some pact 5 upgrade has no transactions" - | any (any (\upg -> null (_pact5UpgradeTransactions upg))) (_versionPact5Upgrades v) ] - -- TODO: check that pact 4 vs pact 5 flags respect the upgrades + , [ "validateVersion: some pact upgrade has no transactions" + | any (any isUpgradeEmpty) (_versionUpgrades v) ] + -- TODO: check that pact 4 vs pact 5 fork height respects the upgrades ] unless (null errors) $ error $ unlines $ ["errors encountered validating version", show v] <> errors + where + isUpgradeEmpty (ForPact4 upg) = null (_pact4UpgradeTransactions upg) + isUpgradeEmpty (ForPact5 upg) = null (_pact5UpgradeTransactions upg) -- | Look up a version in the registry by code. lookupVersionByCode :: HasCallStack => ChainwebVersionCode -> ChainwebVersion diff --git a/src/Chainweb/Version/Testnet.hs b/src/Chainweb/Version/Testnet.hs index 54b59ef3b0..f646e48b3f 100644 --- a/src/Chainweb/Version/Testnet.hs +++ b/src/Chainweb/Version/Testnet.hs @@ -115,7 +115,6 @@ testnet = ChainwebVersion Pact4Coin3 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_261_000 -- 2021-06-17T15:54:14 EnforceKeysetFormats -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_701_000 -- 2021-11-18T17:54:36 Pact42 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_862_000 -- 2021-06-19T03:34:05 - Pact5 -> AllChains ForkNever CheckTxHash -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_889_000 -- 2022-01-24T04:19:24 Chainweb213Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_974_556 -- 2022-02-25 00:00:00 Chainweb214Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 2_134_331 -- 2022-04-21T12:00:00Z @@ -131,6 +130,7 @@ testnet = ChainwebVersion Chainweb223Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 4_100_681 -- 2024-03-06 12:00:00+00:00 Chainweb224Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 4_333_587 -- 2024-05-29 12:00:00+00:00 Chainweb225Pact -> AllChains ForkNever + Pact5Fork -> AllChains ForkNever , _versionGraphs = (to20ChainsTestnet, twentyChainGraph) `Above` @@ -154,27 +154,26 @@ testnet = ChainwebVersion , [(unsafeChainId i, PNN.payloadBlock) | i <- [1..19]] ] } - , _versionPact4Upgrades = chainZip HM.union + , _versionUpgrades = chainZip HM.union (indexByForkHeights testnet [ (CoinV2, onChains $ - [ (unsafeChainId 0, pact4Upgrade MN0.transactions) - , (unsafeChainId 1, pact4Upgrade MN1.transactions) - , (unsafeChainId 2, pact4Upgrade MN2.transactions) - , (unsafeChainId 3, pact4Upgrade MN3.transactions) - , (unsafeChainId 4, pact4Upgrade MN4.transactions) - , (unsafeChainId 5, pact4Upgrade MN5.transactions) - , (unsafeChainId 6, pact4Upgrade MN6.transactions) - , (unsafeChainId 7, pact4Upgrade MN7.transactions) - , (unsafeChainId 8, pact4Upgrade MN8.transactions) - , (unsafeChainId 9, pact4Upgrade MN9.transactions) + [ (unsafeChainId 0, ForPact4 $ pact4Upgrade MN0.transactions) + , (unsafeChainId 1, ForPact4 $ pact4Upgrade MN1.transactions) + , (unsafeChainId 2, ForPact4 $ pact4Upgrade MN2.transactions) + , (unsafeChainId 3, ForPact4 $ pact4Upgrade MN3.transactions) + , (unsafeChainId 4, ForPact4 $ pact4Upgrade MN4.transactions) + , (unsafeChainId 5, ForPact4 $ pact4Upgrade MN5.transactions) + , (unsafeChainId 6, ForPact4 $ pact4Upgrade MN6.transactions) + , (unsafeChainId 7, ForPact4 $ pact4Upgrade MN7.transactions) + , (unsafeChainId 8, ForPact4 $ pact4Upgrade MN8.transactions) + , (unsafeChainId 9, ForPact4 $ pact4Upgrade MN9.transactions) ]) - , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) - , (Chainweb223Pact, AllChains $ pact4Upgrade CoinV6.transactions) + , (Pact4Coin3, AllChains (ForPact4 $ Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, AllChains (ForPact4 $ Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, AllChains (ForPact4 $ Pact4Upgrade CoinV5.transactions True)) + , (Chainweb223Pact, AllChains $ ForPact4 $ pact4Upgrade CoinV6.transactions) ]) - (onChains [(unsafeChainId 0, HM.singleton to20ChainsTestnet (pact4Upgrade MNKAD.transactions))]) - , _versionPact5Upgrades = AllChains mempty + (onChains [(unsafeChainId 0, HM.singleton to20ChainsTestnet (ForPact4 $ pact4Upgrade MNKAD.transactions))]) , _versionCheats = VersionCheats { _disablePow = False , _fakeFirstEpochStart = False diff --git a/src/Chainweb/WebPactExecutionService.hs b/src/Chainweb/WebPactExecutionService.hs index 8973cd1ac1..07ce5b1b63 100644 --- a/src/Chainweb/WebPactExecutionService.hs +++ b/src/Chainweb/WebPactExecutionService.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Chainweb.WebPactExecutionService ( WebPactExecutionService(..) @@ -45,23 +46,25 @@ import Pact.Types.Hash import Pact.Types.Persistence (RowKey, Domain) import Pact.Types.RowData (RowData) import qualified Pact.Core.Persistence as Pact5 +import Chainweb.Version -- -------------------------------------------------------------------------- -- -- PactExecutionService data NewBlock - = NewBlockInProgress !BlockInProgress + = NewBlockInProgress !(ForSomePactVersion BlockInProgress) | NewBlockPayload !ParentHeader !PayloadWithOutputs deriving Show newBlockToPayloadWithOutputs :: NewBlock -> PayloadWithOutputs newBlockToPayloadWithOutputs (NewBlockInProgress bip) - = blockInProgressToPayloadWithOutputs bip + = forAnyPactVersion blockInProgressToPayloadWithOutputs bip newBlockToPayloadWithOutputs (NewBlockPayload _ pwo) = pwo newBlockParentHeader :: NewBlock -> ParentHeader -newBlockParentHeader (NewBlockInProgress bip) = _blockInProgressParentHeader bip +newBlockParentHeader (NewBlockInProgress (ForPact4 bip)) = _blockInProgressParentHeader bip +newBlockParentHeader (NewBlockInProgress (ForPact5 bip)) = _blockInProgressParentHeader bip newBlockParentHeader (NewBlockPayload ph _) = ph -- | Service API for interacting with a single or multi-chain ("Web") pact service. @@ -82,9 +85,10 @@ data PactExecutionService = PactExecutionService IO (Historical NewBlock) ) , _pactContinueBlock :: !( + forall pv. ChainId -> - BlockInProgress -> - IO (Historical BlockInProgress) + BlockInProgress pv -> + IO (Historical (BlockInProgress pv)) ) -- ^ Request a new block to be formed using mempool , _pactLocal :: !( @@ -154,9 +158,9 @@ _webPactNewBlock = _pactNewBlock . _webPactExecutionService _webPactContinueBlock :: WebPactExecutionService -> ChainId - -> BlockInProgress - -> IO (Historical BlockInProgress) -_webPactContinueBlock = _pactContinueBlock . _webPactExecutionService + -> BlockInProgress pv + -> IO (Historical (BlockInProgress pv)) +_webPactContinueBlock w cid bip = _pactContinueBlock (_webPactExecutionService w) cid bip {-# INLINE _webPactContinueBlock #-} _webPactValidateBlock diff --git a/test/Chainweb/Test/Pact4/Checkpointer.hs b/test/Chainweb/Test/Pact4/Checkpointer.hs index be0a018bea..b31cccf891 100644 --- a/test/Chainweb/Test/Pact4/Checkpointer.hs +++ b/test/Chainweb/Test/Pact4/Checkpointer.hs @@ -629,7 +629,7 @@ withRelationalCheckpointerResource withRelationalCheckpointerResource f = withResource initializeSQLite freeSQLiteResource $ \s -> runSQLite f s -addKeyset :: ChainwebPactDbEnv logger -> KeySetName -> KeySet -> IO () +addKeyset :: Pact4Db logger -> KeySetName -> KeySet -> IO () addKeyset (PactDbEnv pactdb mvar) keysetname keyset = _writeRow pactdb Insert KeySets keysetname keyset mvar @@ -659,7 +659,7 @@ runSQLite' runTest sqlEnvIO = runTest $ do where logger = addLabel ("sub-component", "relational-checkpointer") $ dummyLogger -runExec :: forall logger. (Logger logger) => Checkpointer logger -> ChainwebPactDbEnv logger -> Maybe Value -> Text -> IO EvalResult +runExec :: forall logger. (Logger logger) => Checkpointer logger -> Pact4Db logger -> Maybe Value -> Text -> IO EvalResult runExec cp pactdbenv eData eCode = do execMsg <- buildExecParsedCode maxBound {- use latest parser version -} eData eCode evalTransactionM cmdenv cmdst $ @@ -672,7 +672,7 @@ runExec cp pactdbenv eData eCode = do noSPVSupport Nothing 0.0 (RequestKey h') 0 def Nothing Nothing cmdst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty -runCont :: Logger logger => Checkpointer logger -> ChainwebPactDbEnv logger -> PactId -> Int -> IO EvalResult +runCont :: Logger logger => Checkpointer logger -> Pact4Db logger -> PactId -> Int -> IO EvalResult runCont cp pactdbenv pactId step = do evalTransactionM cmdenv cmdst $ applyContinuation' 0 defaultInterpreter contMsg [] h' permissiveNamespacePolicy @@ -692,7 +692,7 @@ runCont cp pactdbenv pactId step = do cpReadFrom :: Checkpointer logger -> Maybe BlockHeader - -> (ChainwebPactDbEnv logger -> IO q) + -> (Pact4Db logger -> IO q) -> IO q cpReadFrom cp pc f = do _cpReadFrom @@ -711,7 +711,7 @@ cpRestoreAndSave :: (Monoid q) => Checkpointer logger -> Maybe BlockHeader - -> [(BlockHeader, ChainwebPactDbEnv logger -> IO q)] + -> [(BlockHeader, Pact4Db logger -> IO q)] -> IO q cpRestoreAndSave cp pc blks = snd <$> _cpRestoreAndSave cp (ParentHeader <$> pc) (traverse Stream.yield diff --git a/test/Chainweb/Test/Pact4/ModuleCacheOnRestart.hs b/test/Chainweb/Test/Pact4/ModuleCacheOnRestart.hs index 61d35bc630..bab9317778 100644 --- a/test/Chainweb/Test/Pact4/ModuleCacheOnRestart.hs +++ b/test/Chainweb/Test/Pact4/ModuleCacheOnRestart.hs @@ -129,7 +129,7 @@ testCoinbase iobdb = (initPayloadState >> doCoinbase,snapshotCache) bdb <- liftIO iobdb bip <- throwIfNoHistory =<< execNewBlock mempty noMiner NewBlockFill (ParentHeader (genesisBlockHeader testVer testChainId)) - let pwo = blockInProgressToPayloadWithOutputs bip + let pwo = forAnyPactVersion blockInProgressToPayloadWithOutputs bip void $ liftIO $ addTestBlockDb bdb (succ genHeight) (Nonce 0) (offsetBlockTime second) testChainId pwo nextH <- liftIO $ getParentTestBlockDb bdb testChainId void $ execValidateBlock mempty nextH (CheckablePayloadWithOutputs pwo) @@ -252,8 +252,8 @@ doNextCoinbase iobdb = do _ <- execValidateBlock mempty prevH (CheckablePayloadWithOutputs pwo') bip <- throwIfNoHistory =<< execNewBlock mempty noMiner NewBlockFill (ParentHeader prevH) - let prevH' = _blockInProgressParentHeader bip - let pwo = blockInProgressToPayloadWithOutputs bip + let prevH' = forAnyPactVersion _blockInProgressParentHeader bip + let pwo = forAnyPactVersion blockInProgressToPayloadWithOutputs bip liftIO $ ParentHeader prevH @?= prevH' void $ liftIO $ addTestBlockDb bdb (succ $ _blockHeight prevH) (Nonce 0) (offsetBlockTime second) testChainId pwo nextH <- liftIO $ getParentTestBlockDb bdb testChainId diff --git a/test/Chainweb/Test/Pact4/NoCoinbase.hs b/test/Chainweb/Test/Pact4/NoCoinbase.hs index 8b4be5e5bc..f1d13dc076 100644 --- a/test/Chainweb/Test/Pact4/NoCoinbase.hs +++ b/test/Chainweb/Test/Pact4/NoCoinbase.hs @@ -23,7 +23,7 @@ import Test.Tasty.HUnit -- internal modules -import Chainweb.Pact.NoCoinbase +import Chainweb.Pact4.NoCoinbase import Chainweb.Payload tests :: TestTree diff --git a/test/Chainweb/Test/Pact4/PactExec.hs b/test/Chainweb/Test/Pact4/PactExec.hs index ba246a9664..e0360c56bd 100644 --- a/test/Chainweb/Test/Pact4/PactExec.hs +++ b/test/Chainweb/Test/Pact4/PactExec.hs @@ -46,7 +46,7 @@ import Chainweb.Logger import Chainweb.Miner.Pact import Chainweb.Pact.PactService import Chainweb.Pact.PactService.Checkpointer -import Chainweb.Pact.PactService.ExecBlock +import Chainweb.Pact.PactService.Pact4.ExecBlock import Chainweb.Pact.Types import Chainweb.Pact.Service.Types import Chainweb.Payload @@ -57,7 +57,7 @@ import Chainweb.Test.Pact4.Utils import Chainweb.Test.Utils import Chainweb.Test.TestVersions import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Version (ChainwebVersion(..)) +import Chainweb.Version (ChainwebVersion(..), PactVersionT(..)) import Chainweb.Version.Utils (someChainId) import Chainweb.Utils hiding (check) @@ -502,9 +502,10 @@ execTest v runPact request = _trEval request $ do trans <- mkCmds cmdStrs results <- runPact $ (throwIfNoHistory =<<) $ readFrom (Just $ ParentHeader $ genesisBlockHeader v cid) $ - execTransactions False defaultMiner - trans (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) Nothing Nothing - >>= throwCommandInvalidError + assertBlockPact4 $ + execTransactions False defaultMiner + trans (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) Nothing Nothing + >>= throwCommandInvalidError let outputs = V.toList $ snd <$> _transactionPairs results return $ TestResponse @@ -533,9 +534,10 @@ execTxsTest v runPact name (trans',check) = testCase name (go >>= check) trans <- trans' results' <- tryAllSynchronous $ runPact $ (throwIfNoHistory =<<) $ readFrom (Just $ ParentHeader $ genesisBlockHeader v cid) $ - execTransactions False defaultMiner trans - (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) Nothing Nothing - >>= throwCommandInvalidError + assertBlockPact4 $ + execTransactions False defaultMiner trans + (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) Nothing Nothing + >>= throwCommandInvalidError case results' of Right results -> Right <$> do let outputs = V.toList $ snd <$> _transactionPairs results @@ -624,7 +626,7 @@ _showValidationFailure = do } miner = defaultMiner header = genesisBlockHeader testVersion $ someChainId testVersion - pwo = toPayloadWithOutputs miner outs1 + pwo = toPayloadWithOutputs Pact4T miner outs1 cr2 = set crGas 1 cr1 outs2 = Transactions { _transactionPairs = V.zip txs (V.singleton cr2) diff --git a/test/Chainweb/Test/Pact4/PactReplay.hs b/test/Chainweb/Test/Pact4/PactReplay.hs index d4fe1b5ca8..8e214b9ad3 100644 --- a/test/Chainweb/Test/Pact4/PactReplay.hs +++ b/test/Chainweb/Test/Pact4/PactReplay.hs @@ -330,7 +330,7 @@ mineBlock ph nonce iop = timeout 5000000 go >>= \case -- assemble block without nonce and timestamp (_, q, bdb) <- iop bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill ph q - let payload = blockInProgressToPayloadWithOutputs bip + let payload = forAnyPactVersion blockInProgressToPayloadWithOutputs bip let creationTime = BlockCreationTime diff --git a/test/Chainweb/Test/Pact4/PactSingleChainTest.hs b/test/Chainweb/Test/Pact4/PactSingleChainTest.hs index 5fb03f2b60..1b15e2659e 100644 --- a/test/Chainweb/Test/Pact4/PactSingleChainTest.hs +++ b/test/Chainweb/Test/Pact4/PactSingleChainTest.hs @@ -188,7 +188,7 @@ runBlockE :: (HasCallStack) => PactQueue -> TestBlockDb -> TimeSpan Micros -> IO runBlockE q bdb timeOffset = do ph <- getParentTestBlockDb bdb cid bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) q - let nb = blockInProgressToPayloadWithOutputs bip + let nb = forAnyPactVersion blockInProgressToPayloadWithOutputs bip let blockTime = add timeOffset $ _bct $ _blockCreationTime ph forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nb @@ -234,7 +234,8 @@ newBlockAndContinue refIO reqIO = testCase "newBlockAndContinue" $ do , V.fromList [ c3 ] ] - bipStart <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q + -- TODO: assert? + ForPact4 bipStart <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q let ParentHeader ph = _blockInProgressParentHeader bipStart bipContinued <- throwIfNoHistory =<< continueBlock bipStart q bipFinal <- throwIfNoHistory =<< continueBlock bipContinued q @@ -265,7 +266,7 @@ newBlockAndContinue refIO reqIO = testCase "newBlockAndContinue" $ do [ c1, c2, c3 ] ] bipAllAtOnce <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q - let nbAllAtOnce = blockInProgressToPayloadWithOutputs bipAllAtOnce + let nbAllAtOnce = forAnyPactVersion blockInProgressToPayloadWithOutputs bipAllAtOnce assertEqual "a continued block, and one that's all done at once, should be exactly equal" nbContinued nbAllAtOnce _ <- validateBlock nextH (CheckablePayloadWithOutputs nbAllAtOnce) q @@ -283,13 +284,13 @@ newBlockNoFill refIO reqIO = testCase "newBlockNoFill" $ do set cbRPC (mkExec "1" (object [])) $ defaultCmd setMempool refIO =<< mempoolOf [V.fromList [c1]] - noFillPwo <- fmap blockInProgressToPayloadWithOutputs . throwIfNoHistory =<< + noFillPwo <- fmap (forAnyPactVersion blockInProgressToPayloadWithOutputs) . throwIfNoHistory =<< newBlock noMiner NewBlockEmpty (ParentHeader genesisHeader) q assertEqual "an unfilled newblock must have no transactions, even with a full mempool" mempty (_payloadWithOutputsTransactions noFillPwo) - fillPwo <- fmap blockInProgressToPayloadWithOutputs . throwIfNoHistory =<< + fillPwo <- fmap (forAnyPactVersion blockInProgressToPayloadWithOutputs) . throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q assertEqual "an filled newblock has transactions with a full mempool" @@ -302,7 +303,7 @@ newBlockAndValidationFailure refIO reqIO = testCase "newBlockAndValidationFailur setOneShotMempool refIO =<< goldenMemPool bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q - let nb = blockInProgressToPayloadWithOutputs bip + let nb = forAnyPactVersion blockInProgressToPayloadWithOutputs bip let blockTime = add second $ _bct $ _blockCreationTime genesisHeader forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nb @@ -771,7 +772,7 @@ blockGasLimitTest _ reqIO = testCase "blockGasLimitTest" $ do (V.singleton (bigTx, cr)) (CommandResult (RequestKey (Hash "h")) Nothing (PactResult $ Right $ pString "output") 0 Nothing Nothing Nothing []) - payload = toPayloadWithOutputs noMiner block + payload = toPayloadWithOutputs Pact4T noMiner block bh = newBlockHeader mempty (_payloadWithOutputsPayloadHash payload) @@ -987,7 +988,7 @@ badlistNewBlockTest mpRefIO reqIO = testCase "badlistNewBlockTest" $ do $ defaultCmd setOneShotMempool mpRefIO (badlistMPA badTx badHashRef) bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) reqQ - let resp = blockInProgressToPayloadWithOutputs bip + let resp = forAnyPactVersion blockInProgressToPayloadWithOutputs bip assertEqual "bad tx filtered from block" mempty (_payloadWithOutputsTransactions resp) badHash <- readIORef badHashRef assertEqual "Badlist should have badtx hash" (hashToTxHashList $ _cmdHash badTx) badHash @@ -1003,16 +1004,19 @@ goldenNewBlock name mpIO mpRefIO reqIO = golden name $ do (_, reqQ, _) <- reqIO setOneShotMempool mpRefIO mp blockInProgress <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) reqQ - let resp = blockInProgressToPayloadWithOutputs blockInProgress + let resp = forAnyPactVersion blockInProgressToPayloadWithOutputs blockInProgress -- ensure all golden txs succeed forM_ (_payloadWithOutputsTransactions resp) $ \(txIn,TransactionOutput out) -> do cr :: CommandResult Hash <- decodeStrictOrThrow out assertSatisfies ("golden tx succeeds, input: " ++ show txIn) (_crResult cr) (isRight . (\(PactResult r) -> r)) - goldenBytes resp blockInProgress + case blockInProgress of + ForPact4 bip -> goldenBytes resp bip + ForPact5 bip -> goldenBytes resp bip where hmToSortedList = List.sortOn fst . HM.toList -- missing some fields, only includes the fields that are "outputs" of -- running txs, but not the module cache + blockInProgressToJSON :: BlockInProgress pv -> Value blockInProgressToJSON BlockInProgress {..} = object [ "pendingData" .= let SQLitePendingData{..} = _blockInProgressPendingData @@ -1036,7 +1040,7 @@ goldenNewBlock name mpIO mpRefIO reqIO = golden name $ do , "blockGasLimit" .= fromIntegral @GasLimit @Int _blockInProgressRemainingGasLimit , "parentHeader" .= _parentHeader _blockInProgressParentHeader ] - goldenBytes :: PayloadWithOutputs -> BlockInProgress -> IO BL.ByteString + goldenBytes :: PayloadWithOutputs -> BlockInProgress pv -> IO BL.ByteString goldenBytes a b = return $ BL.fromStrict $ encodeYaml $ object [ "test-group" .= ("new-block" :: T.Text) , "results" .= a diff --git a/test/Chainweb/Test/Pact4/RewardsTest.hs b/test/Chainweb/Test/Pact4/RewardsTest.hs index 5e45eb79c6..04e9d74791 100644 --- a/test/Chainweb/Test/Pact4/RewardsTest.hs +++ b/test/Chainweb/Test/Pact4/RewardsTest.hs @@ -12,7 +12,7 @@ import Pact.Parse import Chainweb.Graph import Chainweb.Miner.Pact -import Chainweb.Pact.PactService.ExecBlock +import Chainweb.Pact.PactService.Pact4.ExecBlock import Chainweb.Test.TestVersions import Chainweb.Version diff --git a/test/Chainweb/Test/Pact4/TTL.hs b/test/Chainweb/Test/Pact4/TTL.hs index 7c2a4163d4..5ba2ffa9f2 100644 --- a/test/Chainweb/Test/Pact4/TTL.hs +++ b/test/Chainweb/Test/Pact4/TTL.hs @@ -223,7 +223,7 @@ doNewBlock ctxIO mempool parent nonce t = do error "Test failure: mempool access is not empty. Some previous test step failed unexpectedly" bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill parent (_ctxQueue ctx) - let payload = blockInProgressToPayloadWithOutputs bip + let payload = forAnyPactVersion blockInProgressToPayloadWithOutputs bip let creationTime = BlockCreationTime . add (secondsToTimeSpan t) -- 10 seconds diff --git a/test/Chainweb/Test/Pact5/CheckpointerTest.hs b/test/Chainweb/Test/Pact5/CheckpointerTest.hs index daf8901593..ac6184df9a 100644 --- a/test/Chainweb/Test/Pact5/CheckpointerTest.hs +++ b/test/Chainweb/Test/Pact5/CheckpointerTest.hs @@ -131,7 +131,7 @@ hoistDbAction f (DbCreateTable tn es) = DbCreateTable tn (f es) tryShow :: IO a -> IO (Either String a) tryShow = fmap (over _Left show) . tryAny -runDbAction :: CoreDb -> DbAction (Const ()) -> IO (DbAction Identity) +runDbAction :: Pact5Db -> DbAction (Const ()) -> IO (DbAction Identity) runDbAction pactDb act = fmap (hoistDbAction (\(Pair (Const ()) fa) -> fa)) $ runDbAction' pactDb act @@ -139,7 +139,7 @@ runDbAction pactDb act = extractInt :: RowData -> IO Integer extractInt (RowData m) = evaluate (m ^?! ix (Field "k") . _PLiteral . _LInteger) -runDbAction' :: CoreDb -> DbAction f -> IO (DbAction (Product f Identity)) +runDbAction' :: Pact5Db -> DbAction f -> IO (DbAction (Product f Identity)) runDbAction' pactDb = \case DbRead tn k v -> do maybeValue <- tryShow $ _pdbRead pactDb (DUserTables (mkTableName tn)) k diff --git a/test/Chainweb/Test/Pact5/TransactionExecTest.hs b/test/Chainweb/Test/Pact5/TransactionExecTest.hs index 3b523ca78b..0d9aff09ab 100644 --- a/test/Chainweb/Test/Pact5/TransactionExecTest.hs +++ b/test/Chainweb/Test/Pact5/TransactionExecTest.hs @@ -73,7 +73,7 @@ import Chainweb.Version import Chainweb.Miner.Pact (noMiner) import Chainweb.Pact.PactService (initialPayloadState, withPactService) import Chainweb.Pact.PactService.Checkpointer (readFrom, restoreAndSave) -import Chainweb.Pact.PactService.ExecBlock +import Chainweb.Pact.PactService.Pact4.ExecBlock import Chainweb.Pact4.TransactionExec (applyGenesisCmd) import Chainweb.Pact5.Transaction import Chainweb.Pact5.TransactionExec @@ -112,7 +112,20 @@ import Data.Maybe (fromMaybe) import GHC.Stack import Data.Decimal import PredicateTransformers as PT +import Data.Text (Text) +coinModule :: ModuleName +coinModule = ModuleName "coin" Nothing + +-- usually we don't want to check the module hash +event :: Predicatory p => Pred p Text -> Pred p [PactValue] -> Pred p ModuleName -> Pred p (PactEvent PactValue) +event n args mod = satAll + [ pt _peName n + , pt _peArgs args + , pt _peModule mod + ] + +-- TODO: test for verifiers, test for upgrades, test for coin.transfer in an applyCmd call? tests :: RocksDb -> TestTree tests baseRdb = testGroup "Pact5 TransactionExecTest" [ testCase "buyGas should take gas tokens from the transaction sender" $ runResourceT $ do @@ -279,6 +292,7 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" , pt _crLogs . equals $ Just [] ] + endSender00Bal <- readBal pactDb "sender00" assertEqual "ending balance should be equal" startSender00Bal endSender00Bal endMinerBal <- readBal pactDb "NoMiner" @@ -315,14 +329,15 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" } let txCtx = TxContext {_tcParentHeader = ParentHeader gh, _tcMiner = noMiner} let expectedGasConsumed = 159 - commandResult <- applyCmd v dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) + commandResult <- applyCmd dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) () <- commandResult & satAll -- gas buy event - [ pt _crEvents . soleElement $ satAll - [ pt _peName . equals $ "TRANSFER" - , pt _peArgs . equals $ [PString "sender00", PString "NoMiner", PDecimal 318.0] - , pt _peModule . equals $ ModuleName "coin" Nothing - ] + + [ pt _crEvents . soleElement $ + event + (equals "TRANSFER") + (equals [PString "sender00", PString "NoMiner", PDecimal 318.0]) + (equals coinModule) , pt _crResult . equals $ PactResultOk (PInteger 15) -- reflects buyGas gas usage, as well as that of the payload , pt _crGas . equals $ Gas expectedGasConsumed @@ -389,15 +404,14 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" , _cbGasLimit = GasLimit (Gas 70_000) } let txCtx = TxContext {_tcParentHeader = ParentHeader gh, _tcMiner = noMiner} - commandResult <- applyCmd v dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) + commandResult <- applyCmd dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) commandResult & satAll @(IO ()) @_ -- gas buy event [ pt _crEvents $ PT.list - [ satAll - [ pt _peName . equals $ "TRANSFER" - , pt _peArgs . equals $ [PString "sender00", PString "NoMiner", PDecimal 120316] - , pt _peModule . equals $ ModuleName "coin" Nothing - ] + [ event + (equals "TRANSFER") + (equals [PString "sender00", PString "NoMiner", PDecimal 120316]) + (equals coinModule) ] , pt _crResult . equals $ PactResultOk (PString "Loaded module 02ebLE2w4YnM0JLBWjqpAmUtqdpMsdJgb-4DEm7ZwIs") -- reflects buyGas gas usage, as well as that of the payload @@ -421,7 +435,6 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" [ pt _txDomain . equals $ "USER_coin_coin-table" , pt _txKey . equals $ "sender00" ] - ] ] @@ -466,15 +479,14 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" , _cbGasLimit = GasLimit (Gas 300) } let txCtx = TxContext {_tcParentHeader = ParentHeader gh, _tcMiner = noMiner} - commandResult <- applyCmd v dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) + commandResult <- applyCmd dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) commandResult & satAll @(IO ()) @_ -- gas buy event [ pt _crEvents $ PT.list - [ satAll - [ pt _peName . equals $ "TRANSFER" - , pt _peArgs . equals $ [PString "sender00", PString "NoMiner", PDecimal 336] - , pt _peModule . equals $ ModuleName "coin" Nothing - ] + [ event + (equals "TRANSFER") + (equals [PString "sender00", PString "NoMiner", PDecimal 336]) + (equals coinModule) ] , pt _crResult . equals $ PactResultOk (PInteger 1) -- reflects buyGas gas usage, as well as that of the payload @@ -515,7 +527,6 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal startMinerBal <- readBal pactDb "NoMiner" - let coinModule = ModuleName "coin" Nothing cmd <- buildCwCmd "nonce" v defaultCmd { _cbRPC = mkExec' "(coin.transfer 'sender00 'sender01 420.0)" @@ -532,20 +543,18 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" let txCtx = TxContext {_tcParentHeader = ParentHeader gh, _tcMiner = noMiner} -- Note: if/when core changes gas prices, tweak here. let expectedGasConsumed = 509 - commandResult <- applyCmd v dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) + commandResult <- applyCmd dummyLogger Nothing pactDb txCtx noSPVSupport (_payloadObj <$> cmd) (Gas 1) () <- commandResult & satAll -- gas buy event [ pt _crEvents $ PT.list - [ satAll - [ pt _peName . equals $ "TRANSFER" - , pt _peArgs . equals $ [PString "sender00", PString "sender01", PDecimal 420] - , pt _peModule . equals $ coinModule - ] - , satAll - [ pt _peName . equals $ "TRANSFER" - , pt _peArgs . equals $ [PString "sender00", PString "NoMiner", PDecimal 1018] - , pt _peModule . equals $ coinModule - ] + [ event + (equals "TRANSFER") + (equals [PString "sender00", PString "sender01", PDecimal 420]) + (equals coinModule) + , event + (equals "TRANSFER") + (equals [PString "sender00", PString "NoMiner", PDecimal 1018]) + (equals coinModule) ] , pt _crResult . equals $ PactResultOk (PString "Write succeeded") -- reflects buyGas gas usage, as well as that of the payload @@ -603,7 +612,7 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" startMinerBal <- readBal pactDb "NoMiner" let txCtx = TxContext {_tcParentHeader = ParentHeader gh, _tcMiner = noMiner} - r <- applyCoinbase v dummyLogger pactDb 5 txCtx + r <- applyCoinbase dummyLogger pactDb 5 txCtx () <- r & satAll [ pt _crResult . equals $ PactResultOk (PString "Write succeeded") , pt _crGas . equals $ Gas 0 @@ -613,11 +622,11 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" , pt _txKey . equals $ "NoMiner" ] ] - , pt _crEvents . soleElement $ satAll - [ pt _peName . equals $ "TRANSFER" - , pt _peArgs . equals $ [PString "", PString "NoMiner", PDecimal 5.0] - , pt _peModule . equals $ ModuleName "coin" Nothing - ] + , pt _crEvents . soleElement $ + event + (equals "TRANSFER") + (equals [PString "", PString "NoMiner", PDecimal 5.0]) + (equals coinModule) ] endMinerBal <- readBal pactDb "NoMiner" assertEqual "miner balance should include block reward" diff --git a/test/Chainweb/Test/TestVersions.hs b/test/Chainweb/Test/TestVersions.hs index 2529fb1dd8..c4f959104d 100644 --- a/test/Chainweb/Test/TestVersions.hs +++ b/test/Chainweb/Test/TestVersions.hs @@ -153,7 +153,7 @@ fastForks = tabulateHashMap $ \case PactEvents -> AllChains ForkAtGenesis CoinV2 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1 Pact42 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1 - Pact5 -> AllChains $ ForkAtBlockHeight 42 + Pact5Fork -> AllChains $ ForkAtBlockHeight 42 SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 ModuleNameFix -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 ModuleNameFix2 -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 @@ -194,8 +194,7 @@ barebonesTestVersion g = buildTestVersion $ \v -> , _genesisTime = AllChains $ BlockCreationTime epoch } & versionForks .~ HM.fromList [ (f, AllChains ForkAtGenesis) | f <- [minBound..maxBound] ] - & versionPact4Upgrades .~ AllChains HM.empty - & versionPact5Upgrades .~ AllChains HM.empty + & versionUpgrades .~ AllChains HM.empty -- | A test version without Pact or PoW, with a chain graph upgrade at block height 8. timedConsensusVersion :: ChainGraph -> ChainGraph -> ChainwebVersion @@ -209,8 +208,7 @@ timedConsensusVersion g1 g2 = buildTestVersion $ \v -> v -- pact is disabled, we don't care about pact forks _ -> AllChains ForkAtGenesis ) - & versionPact4Upgrades .~ AllChains HM.empty - & versionPact5Upgrades .~ AllChains HM.empty + & versionUpgrades .~ AllChains HM.empty & versionGraphs .~ (BlockHeight 8, g2) `Above` (End g1) & versionCheats .~ VersionCheats { _disablePow = True @@ -241,8 +239,7 @@ pact5CheckpointerTestVersion g1 = buildTestVersion $ \v -> v -- pact is disabled, we don't care about pact forks _ -> AllChains ForkAtGenesis ) - & versionPact4Upgrades .~ AllChains HM.empty - & versionPact5Upgrades .~ AllChains HM.empty + & versionUpgrades .~ AllChains HM.empty & versionGraphs .~ End g1 & versionCheats .~ VersionCheats { _disablePow = True @@ -282,16 +279,15 @@ cpmTestVersion g v = v , _genesisBlockTarget = AllChains maxTarget , _genesisTime = AllChains $ BlockCreationTime epoch } - & versionPact4Upgrades .~ chainZip HM.union + & versionUpgrades .~ chainZip HM.union (indexByForkHeights v - [ (CoinV2, AllChains (pact4Upgrade Other.transactions)) - , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) - , (Chainweb223Pact, AllChains (pact4Upgrade CoinV6.transactions)) + [ (CoinV2, AllChains (ForPact4 $ pact4Upgrade Other.transactions)) + , (Pact4Coin3, AllChains (ForPact4 $ Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, AllChains (ForPact4 $ Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, AllChains (ForPact4 $ Pact4Upgrade CoinV5.transactions True)) + , (Chainweb223Pact, AllChains (ForPact4 $ pact4Upgrade CoinV6.transactions)) ]) - (onChains [(unsafeChainId 3, HM.singleton (BlockHeight 2) (Pact4Upgrade MNKAD.transactions False))]) - & versionPact5Upgrades .~ AllChains HM.empty + (onChains [(unsafeChainId 3, HM.singleton (BlockHeight 2) (ForPact4 $ Pact4Upgrade MNKAD.transactions False))]) slowForks :: HashMap Fork (ChainMap ForkHeight) slowForks = tabulateHashMap \case @@ -308,7 +304,7 @@ slowForks = tabulateHashMap \case ModuleNameFix -> AllChains $ ForkAtBlockHeight (BlockHeight 2) ModuleNameFix2 -> AllChains $ ForkAtBlockHeight (BlockHeight 2) Pact42 -> AllChains $ ForkAtBlockHeight (BlockHeight 5) - Pact5 -> AllChains $ ForkAtBlockHeight (BlockHeight 115) + Pact5Fork -> AllChains $ ForkAtBlockHeight (BlockHeight 115) CheckTxHash -> AllChains $ ForkAtBlockHeight (BlockHeight 7) EnforceKeysetFormats -> AllChains $ ForkAtBlockHeight (BlockHeight 10) PactEvents -> AllChains $ ForkAtBlockHeight (BlockHeight 10) @@ -371,7 +367,7 @@ instantCpmTestVersion g = buildTestVersion $ \v -> v & versionName .~ ChainwebVersionName ("instant-CPM-" <> toText g) & versionForks .~ tabulateHashMap (\case -- genesis blocks are not ever run with Pact 5 - Pact5 -> onChains [ (cid, ForkAtBlockHeight (succ $ genesisHeightSlow v cid)) | cid <- HS.toList $ graphChainIds g ] + Pact5Fork -> onChains [ (cid, ForkAtBlockHeight (succ $ genesisHeightSlow v cid)) | cid <- HS.toList $ graphChainIds g ] _ -> AllChains ForkAtGenesis ) & versionGenesis .~ VersionGenesis @@ -381,8 +377,7 @@ instantCpmTestVersion g = buildTestVersion $ \v -> v , _genesisBlockTarget = AllChains maxTarget , _genesisTime = AllChains $ BlockCreationTime epoch } - & versionPact4Upgrades .~ AllChains mempty - & versionPact5Upgrades .~ AllChains mempty + & versionUpgrades .~ AllChains mempty & versionVerifierPluginNames .~ AllChains (End $ Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message"]) @@ -390,4 +385,4 @@ pact5EarlyTestVersion :: ChainGraph -> ChainwebVersion pact5EarlyTestVersion g = buildTestVersion $ \v -> v & cpmTestVersion g & versionName .~ ChainwebVersionName ("pact5-early-" <> toText g) - & versionForks .~ (fastForks & at Pact5 .~ Just (AllChains $ ForkAtBlockHeight 115)) + & versionForks .~ (fastForks & at Pact5Fork .~ Just (AllChains $ ForkAtBlockHeight 115)) diff --git a/tools/cwtool/TxSimulator.hs b/tools/cwtool/TxSimulator.hs index e82e8c3438..8a652d479d 100644 --- a/tools/cwtool/TxSimulator.hs +++ b/tools/cwtool/TxSimulator.hs @@ -37,7 +37,7 @@ import Chainweb.Pact.Backend.Types import Chainweb.Pact.Backend.Utils import Chainweb.Pact.PactService import Chainweb.Pact.PactService.Checkpointer -import Chainweb.Pact.PactService.ExecBlock +import Chainweb.Pact.PactService.Pact4.ExecBlock import Chainweb.Pact.RestAPI.Server import Chainweb.Pact.Service.Types import Chainweb.Pact.TransactionExec