PactService.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}

-- |
-- Module: Chainweb.Pact.PactService
-- Copyright: Copyright © 2018,2019,2020 Kadena LLC.
-- License: See LICENSE file
-- Maintainers: Lars Kuhtz, Emily Pillmore, Stuart Popejoy
-- Stability: experimental
--
-- Pact service for Chainweb
--
module Chainweb.Pact.PactService
    ( initialPayloadState
    , execNewBlock
    , execContinueBlock
    , execValidateBlock
    , execTransactions
    , execLocal
    , execLookupPactTxs
    , execPreInsertCheckReq
    , execBlockTxHistory
    , execHistoricalLookup
    , execReadOnlyReplay
    , execSyncToBlock
    , runPactService
    , withPactService
    , execNewGenesisBlock
    ) where

import Control.Concurrent hiding (throwTo)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (AsyncException(ThreadKilled))
import Control.Exception.Safe
import Control.Lens hiding ((:>))
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State.Strict

import Data.Either
import Data.Foldable (toList)
import Data.IORef
import qualified Data.HashMap.Strict as HM
import Data.LogMessage
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID

import System.IO
import System.LogLevel

import Prelude hiding (lookup)

import qualified Streaming as Stream
import qualified Streaming.Prelude as Stream

import qualified Pact.Gas as Pact4
import Pact.Interpreter(PactDbEnv(..))
import qualified Pact.JSON.Encode as J
import qualified Pact.Types.Command as Pact4
import qualified Pact.Types.Hash as Pact4
import qualified Pact.Types.Runtime as Pact4 hiding (catchesPactError)
import qualified Pact.Types.Pretty as Pact4

import qualified Pact.Core.Builtin as Pact5
import qualified Pact.Core.Persistence as Pact5
import qualified Pact.Core.Gas as Pact5
import qualified Pact.Core.Info as Pact5
import qualified Pact.Core.Command.Types as Pact5
import qualified Pact.Core.Command.RPC as Pact5
import qualified Pact.Core.Hash as Pact5

import qualified Chainweb.Pact4.TransactionExec as Pact4
import qualified Chainweb.Pact4.Validations as Pact4

import Chainweb.BlockHash
import Chainweb.BlockHeader
import Chainweb.BlockHeaderDB
import Chainweb.BlockHeight
import Chainweb.ChainId
import Chainweb.Logger
import Chainweb.Mempool.Mempool as Mempool
import Chainweb.Miner.Pact

import Chainweb.Pact.PactService.Pact4.ExecBlock
import qualified Chainweb.Pact4.Backend.ChainwebPactDb as Pact4
import Chainweb.Pact.Service.PactQueue (PactQueue, getNextRequest)
import Chainweb.Pact.Types
import Chainweb.Pact4.SPV qualified as Pact4
import Chainweb.Pact5.SPV qualified as Pact5
import Chainweb.Payload
import Chainweb.Payload.PayloadStore
import Chainweb.Time
import qualified Chainweb.Pact4.Transaction as Pact4
import Chainweb.TreeDB
import Chainweb.Utils hiding (check)
import Chainweb.Version
import Chainweb.Version.Guards
import Utils.Logging.Trace
import Chainweb.Counter
import Data.Time.Clock
import Text.Printf
import Data.Time.Format.ISO8601
import qualified Chainweb.Pact.PactService.Pact4.ExecBlock as Pact4
import qualified Chainweb.Pact4.Types as Pact4
import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5
import qualified Data.ByteString.Short as SB
import Data.Coerce (coerce)
import Data.Void
import qualified Chainweb.Pact5.Types as Pact5
import qualified Chainweb.Pact.PactService.Pact5.ExecBlock as Pact5
import qualified Pact.Core.Evaluate as Pact5
import qualified Pact.Core.Names as Pact5
import Data.Functor.Product
import qualified Chainweb.Pact5.TransactionExec as Pact5
import qualified Chainweb.Pact5.Transaction as Pact5
import Control.Monad.Except
import qualified Chainweb.Pact5.NoCoinbase as Pact5
import qualified Pact.Parse as Pact4
import qualified Control.Parallel.Strategies as Strategies
import qualified Chainweb.Pact5.Validations as Pact5
import qualified Pact.Core.Errors as Pact5
import Chainweb.Pact.Backend.Types
import qualified Chainweb.Pact.PactService.Checkpointer as Checkpointer
import Chainweb.Pact.PactService.Checkpointer (SomeBlockM(..))
import qualified Pact.Core.StableEncoding as Pact5
import Control.Monad.Cont (evalContT)
import qualified Data.List.NonEmpty as NonEmpty


runPactService
    :: Logger logger
    => CanReadablePayloadCas tbl
    => ChainwebVersion
    -> ChainId
    -> logger
    -> Maybe (Counter "txFailures")
    -> PactQueue
    -> MemPoolAccess
    -> BlockHeaderDb
    -> PayloadDb tbl
    -> SQLiteEnv
    -> PactServiceConfig
    -> IO ()
runPactService ver cid chainwebLogger txFailuresCounter reqQ mempoolAccess bhDb pdb sqlenv config =
    void $ withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config $ do
        initialPayloadState ver cid
        serviceRequests mempoolAccess reqQ

withPactService
    :: (Logger logger, CanReadablePayloadCas tbl)
    => ChainwebVersion
    -> ChainId
    -> logger
    -> Maybe (Counter "txFailures")
    -> BlockHeaderDb
    -> PayloadDb tbl
    -> SQLiteEnv
    -> PactServiceConfig
    -> PactServiceM logger tbl a
    -> IO (T2 a PactServiceState)
withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config act = do
    Checkpointer.withCheckpointerResources checkpointerLogger (_pactModuleCacheLimit config) sqlenv (_pactPersistIntraBlockWrites config) ver cid $ \checkpointer -> do
        let !rs = readRewards
        let !pse = PactServiceEnv
                    { _psMempoolAccess = Nothing
                    , _psCheckpointer = checkpointer
                    , _psPdb = pdb
                    , _psBlockHeaderDb = bhDb
                    , _psMinerRewards = rs
                    , _psReorgLimit = _pactReorgLimit config
                    , _psPreInsertCheckTimeout = _pactPreInsertCheckTimeout config
                    , _psOnFatalError = defaultOnFatalError (logFunctionText chainwebLogger)
                    , _psVersion = ver
                    , _psAllowReadsInLocal = _pactAllowReadsInLocal config
                    , _psLogger = pactServiceLogger
                    , _psGasLogger = gasLogger <$ guard (_pactLogGas config)
                    , _psBlockGasLimit = _pactNewBlockGasLimit config
                    , _psEnableLocalTimeout = _pactEnableLocalTimeout config
                    , _psTxFailuresCounter = txFailuresCounter
                    , _psTxTimeLimit = _pactTxTimeLimit config
                    }
            !pst = PactServiceState mempty

        runPactServiceM pst pse $ do
            when (_pactFullHistoryRequired config) $ do
                mEarliestBlock <- Checkpointer.getEarliestBlock
                case mEarliestBlock of
                    Nothing -> do
                        pure ()
                    Just (earliestBlockHeight, _) -> do
                        let gHeight = genesisHeight ver cid
                        when (gHeight /= earliestBlockHeight) $ do
                            let msg = J.object
                                    [ "details" J..= J.object
                                        [ "earliest-block-height" J..= J.number (fromIntegral earliestBlockHeight)
                                        , "genesis-height" J..= J.number (fromIntegral gHeight)
                                        ]
                                    , "message" J..= J.text "Your node has been configured\
                                        \ to require the full Pact history; however, the full\
                                        \ history is not available. Perhaps you have compacted\
                                        \ your Pact state?"
                                    ]
                            logError_ chainwebLogger (J.encodeText msg)
                            throwM FullHistoryRequired
                                    { _earliestBlockHeight = earliestBlockHeight
                                    , _genesisHeight = gHeight
                                    }
            -- If the latest header that is stored in the checkpointer was on an
            -- orphaned fork, there is no way to recover it in the call of
            -- 'initalPayloadState.readContracts'. We therefore rewind to the latest
            -- avaliable header in the block header database.
            --
            Checkpointer.exitOnRewindLimitExceeded $ initializeLatestBlock (_pactUnlimitedInitialRewind config)
            act
  where
    pactServiceLogger = setComponent "pact" chainwebLogger
    checkpointerLogger = addLabel ("sub-component", "checkpointer") pactServiceLogger
    gasLogger = addLabel ("transaction", "GasLogs") pactServiceLogger

initializeLatestBlock :: (Logger logger) => CanReadablePayloadCas tbl => Bool -> PactServiceM logger tbl ()
initializeLatestBlock unlimitedRewind = Checkpointer.findLatestValidBlockHeader' >>= \case
    Nothing -> return ()
    Just b -> Checkpointer.rewindToIncremental initialRewindLimit (ParentHeader b)
  where
    initialRewindLimit = RewindLimit 1000 <$ guard (not unlimitedRewind)

initialPayloadState
    :: Logger logger
    => CanReadablePayloadCas tbl
    => ChainwebVersion
    -> ChainId
    -> PactServiceM logger tbl ()
initialPayloadState v cid
    | v ^. versionCheats . disablePact = pure ()
    | otherwise = initializeCoinContract v cid $
        v ^?! versionGenesis . genesisBlockPayload . atChain cid

initializeCoinContract
    :: forall tbl logger. (CanReadablePayloadCas tbl, Logger logger)
    => ChainwebVersion
    -> ChainId
    -> PayloadWithOutputs
    -> PactServiceM logger tbl ()
initializeCoinContract v cid pwo = do
    latestBlock <- Checkpointer.getLatestBlock >>= \case
        Nothing -> return Nothing
        Just (_, latestHash) -> do
            latestHeader <- ParentHeader
                <$!> lookupBlockHeader latestHash "initializeCoinContract.findLatestValidBlockHeader"
            return $ Just latestHeader

    case latestBlock of
        Nothing -> do
            logWarnPact "initializeCoinContract: Checkpointer returned no latest block. Starting from genesis."
            validateGenesis
        Just currentBlockHeader ->
            if currentBlockHeader /= ParentHeader genesisHeader
            then
                unless (pact5 v cid (view (parentHeader . blockHeight . to succ) currentBlockHeader)) $ do
                    !mc <- Checkpointer.readFrom (Just currentBlockHeader)
                        (SomeBlockM $ Pair Pact4.readInitModules (error "pact5")) >>= \case
                            NoHistory -> throwM $ BlockHeaderLookupFailure
                                $ "initializeCoinContract: internal error: latest block not found: " <> sshow currentBlockHeader
                            Historical mc -> return mc
                    Pact4.updateInitCache mc currentBlockHeader
            else do
                logWarnPact "initializeCoinContract: Starting from genesis."
                validateGenesis
  where
    validateGenesis = void $!
        execValidateBlock mempty genesisHeader (CheckablePayloadWithOutputs pwo)

    genesisHeader :: BlockHeader
    genesisHeader = genesisBlockHeader v cid

-- | Lookup a block header.
--
-- The block header is expected to be either in the block header database or to
-- be the the currently stored '_psParentHeader'. The latter addresses the case
-- when a block has already been validate with 'execValidateBlock' but isn't (yet)
-- available in the block header database. If that's the case two things can
-- happen:
--
-- 1. the header becomes available before the next 'execValidateBlock' call, or
-- 2. the header gets orphaned and the next 'execValidateBlock' call would cause
--    a rewind to an ancestor, which is available in the db.
--
lookupBlockHeader :: BlockHash -> Text -> PactServiceM logger tbl BlockHeader
lookupBlockHeader bhash ctx = do
    bhdb <- view psBlockHeaderDb
    liftIO $! lookupM bhdb bhash `catchAllSynchronous` \e ->
        throwM $ BlockHeaderLookupFailure $
            "failed lookup of parent header in " <> ctx <> ": " <> sshow e

-- | Loop forever, serving Pact execution requests and reponses from the queues
serviceRequests
    :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl)
    => MemPoolAccess
    -> PactQueue
    -> PactServiceM logger tbl ()
serviceRequests memPoolAccess reqQ = go
  where
    go :: PactServiceM logger tbl ()
    go = do
        PactServiceEnv{_psLogger} <- ask
        logDebugPact "serviceRequests: wait"
        SubmittedRequestMsg msg statusRef <- liftIO $ getNextRequest reqQ
        requestId <- liftIO $ UUID.toText <$> UUID.nextRandom
        let
          logFn :: LogFunction
          logFn = logFunction $ addLabel ("pact-request-id", requestId) _psLogger
        logDebugPact $ "serviceRequests: " <> sshow msg
        case msg of
            CloseMsg ->
                tryOne "execClose" statusRef $ return ()
            LocalMsg (LocalReq localRequest preflight sigVerify rewindDepth) -> do
                trace logFn "Chainweb.Pact.PactService.execLocal" () 0 $
                    tryOne "execLocal" statusRef $
                        execLocal localRequest preflight sigVerify rewindDepth
                go
            NewBlockMsg NewBlockReq {..} -> do
                trace logFn "Chainweb.Pact.PactService.execNewBlock"
                    () 1 $
                    tryOne "execNewBlock" statusRef $
                        execNewBlock memPoolAccess _newBlockMiner _newBlockFill _newBlockParent
                go
            ContinueBlockMsg (ContinueBlockReq bip) -> do
                trace logFn "Chainweb.Pact.PactService.execContinueBlock"
                    () 1 $
                    tryOne "execContinueBlock" statusRef $
                        execContinueBlock memPoolAccess bip
                go
            ValidateBlockMsg ValidateBlockReq {..} -> do
                tryOne "execValidateBlock" statusRef $
                    fmap fst $ trace' logFn "Chainweb.Pact.PactService.execValidateBlock"
                        (\_ -> _valBlockHeader)
                        (\(_, g) -> fromIntegral g)
                        (execValidateBlock memPoolAccess _valBlockHeader _valCheckablePayload)
                go
            LookupPactTxsMsg (LookupPactTxsReq confDepth txHashes) -> do
                trace logFn "Chainweb.Pact.PactService.execLookupPactTxs" ()
                    (length txHashes) $
                    tryOne "execLookupPactTxs" statusRef $
                        execLookupPactTxs confDepth txHashes
                go
            PreInsertCheckMsg (PreInsertCheckReq txs) -> do
                trace logFn "Chainweb.Pact.PactService.execPreInsertCheckReq" ()
                    (length txs) $
                    tryOne "execPreInsertCheckReq" statusRef $
                        execPreInsertCheckReq txs
                go
            BlockTxHistoryMsg (BlockTxHistoryReq bh d) -> do
                trace logFn "Chainweb.Pact.PactService.execBlockTxHistory" bh 1 $
                    tryOne "execBlockTxHistory" statusRef $
                        execBlockTxHistory bh d
                go
            HistoricalLookupMsg (HistoricalLookupReq bh d k) -> do
                trace logFn "Chainweb.Pact.PactService.execHistoricalLookup" bh 1 $
                    tryOne "execHistoricalLookup" statusRef $
                        execHistoricalLookup bh d k
                go
            SyncToBlockMsg SyncToBlockReq {..} -> do
                trace logFn "Chainweb.Pact.PactService.execSyncToBlock" _syncToBlockHeader 1 $
                    tryOne "syncToBlockBlock" statusRef $
                        execSyncToBlock _syncToBlockHeader
                go
            ReadOnlyReplayMsg ReadOnlyReplayReq {..} -> do
                trace logFn "Chainweb.Pact.PactService.execReadOnlyReplay" (_readOnlyReplayLowerBound, _readOnlyReplayUpperBound) 1 $
                    tryOne "readOnlyReplayBlock" statusRef $
                        execReadOnlyReplay _readOnlyReplayLowerBound _readOnlyReplayUpperBound
                go

    tryOne
        :: forall a. Text
        -> TVar (RequestStatus a)
        -> PactServiceM logger tbl a
        -> PactServiceM logger tbl ()
    tryOne which statusRef act =
        evalPactOnThread
        `catches`
            [ Handler $ \(e :: SomeException) -> do
                logErrorPact $ mconcat
                    [ "Received exception running pact service ("
                    , which
                    , "): "
                    , sshow e
                    ]
                liftIO $ throwIO e
            ]
        where
        -- here we start a thread to service the request
        evalPactOnThread :: PactServiceM logger tbl ()
        evalPactOnThread = do
            maybeException <- withPactState $ \run -> do
                goLock <- newEmptyMVar
                finishedLock <- newEmptyMVar
                -- fork a thread to service the request
                bracket
                    (mask_ $ forkIOWithUnmask $ \restore ->
                        -- We wrap this whole block in `tryAsync` because we
                        -- want to ignore `RequestCancelled` exceptions that
                        -- occur while we are waiting on `takeMVar goLock`.
                        --
                        -- Otherwise we get logs like `chainweb-node:
                        -- RequestCancelled`.
                        --
                        -- We don't actually care about whether or not
                        -- `RequestCancelled` was encountered, so we just `void`
                        -- it.
                        void $ tryAsync @_ @RequestCancelled $ flip finally (tryPutMVar finishedLock ()) $ do
                            -- wait until we've been told to start.
                            -- we don't want to start if the request was cancelled
                            -- already
                            takeMVar goLock

                            -- run and report the answer.
                            restore (tryAny (run act)) >>= \case
                                Left ex -> atomically $ writeTVar statusRef (RequestFailed ex)
                                Right r -> atomically $ writeTVar statusRef (RequestDone r)
                    )
                    -- if Pact itself is killed, kill the request thread too.
                    (\tid -> throwTo tid RequestCancelled >> takeMVar finishedLock)
                    (\_tid -> do
                        -- check first if the request has been cancelled before
                        -- starting work on it
                        beforeStarting <- atomically $ do
                            readTVar statusRef >>= \case
                                RequestInProgress -> internalError "request in progress before starting"
                                RequestDone _ -> internalError "request finished before starting"
                                RequestFailed e -> return (Left e)
                                RequestNotStarted -> do
                                    writeTVar statusRef RequestInProgress
                                    return (Right ())
                        case beforeStarting of
                            -- the request has already been cancelled, don't
                            -- start work on it.
                            Left ex -> return (Left ex)
                            Right () -> do
                                -- let the request thread start working
                                putMVar goLock ()
                                -- wait until the request thread has finished
                                atomically $ readTVar statusRef >>= \case
                                    RequestInProgress -> retry
                                    RequestDone _ -> return (Right ())
                                    RequestFailed e -> return (Left e)
                                    RequestNotStarted -> internalError "request not started after starting"
                    )
            case maybeException of
                Left (fromException -> Just AsyncCancelled) -> do
                    logDebugPact "Pact action was cancelled"
                Left (fromException -> Just ThreadKilled) -> do
                    logWarnPact "Pact action thread was killed"
                Left (exn :: SomeException) -> do
                    logErrorPact $ mconcat
                        [ "Received exception running pact service ("
                        , which
                        , "): "
                        , sshow exn
                        ]
                Right () -> return ()

execNewBlock
    :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl)
    => MemPoolAccess
    -> Miner
    -> NewBlockFill
    -> ParentHeader
    -> PactServiceM logger tbl (Historical (ForSomePactVersion BlockInProgress))
execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do
    let pHeight = view blockHeight $ _parentHeader newBlockParent
    let pHash = view blockHash $ _parentHeader newBlockParent
    logInfoPact $ "(parent height = " <> sshow pHeight <> ")"
        <> " (parent hash = " <> sshow pHash <> ")"
    blockGasLimit <- view psBlockGasLimit
    v <- view chainwebVersion
    cid <- view chainId
    Checkpointer.readFrom (Just newBlockParent) $
        -- TODO: after the Pact 5 fork is complete, the Pact 4 case below will
        -- be unnecessary; the genesis blocks are already handled by 'execNewGenesisBlock'.
        SomeBlockM $ Pair
            (do
                blockDbEnv <- view psBlockDbEnv
                initCache <- initModuleCacheForBlock
                coinbaseOutput <- Pact4.runCoinbase
                    miner
                    (Pact4.EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled True)
                    initCache
                let pactDb = Pact4._cpPactDbEnv blockDbEnv
                finalBlockState <- fmap Pact4._benvBlockState
                    $ liftIO
                    $ readMVar
                    $ pdPactDbVar
                    $ pactDb
                let blockInProgress = BlockInProgress
                        { _blockInProgressModuleCache = Pact4ModuleCache initCache
                        -- ^ we do not use the module cache populated by coinbase in
                        -- subsequent transactions
                        , _blockInProgressHandle = BlockHandle (Pact4._bsTxId finalBlockState) (Pact4._bsPendingBlock finalBlockState)
                        , _blockInProgressParentHeader = Just newBlockParent
                        , _blockInProgressRemainingGasLimit = blockGasLimit
                        , _blockInProgressTransactions = Transactions
                            { _transactionCoinbase = coinbaseOutput
                            , _transactionPairs = mempty
                            }
                        , _blockInProgressMiner = miner
                        , _blockInProgressPactVersion = Pact4T
                        , _blockInProgressChainwebVersion = v
                        , _blockInProgressChainId = cid
                        }
                case fill of
                    NewBlockFill -> ForPact4 <$> Pact4.continueBlock mpAccess blockInProgress
                    NewBlockEmpty -> return (ForPact4 blockInProgress)
            )

            (do
                coinbaseOutput <- Pact5.runCoinbase miner >>= \case
                    Left coinbaseError -> internalError $ "Error during coinbase: " <> sshow coinbaseError
                    Right coinbaseOutput ->
                        -- pretend that coinbase can throw an error, when we know it can't.
                        -- perhaps we can make the Transactions express this, may not be worth it.
                        return $ coinbaseOutput & Pact5.crResult . Pact5._PactResultErr %~ absurd
                hndl <- use Pact5.pbBlockHandle
                let blockInProgress = BlockInProgress
                        { _blockInProgressModuleCache = Pact5NoModuleCache
                        , _blockInProgressHandle = hndl
                        , _blockInProgressParentHeader = Just newBlockParent
                        , _blockInProgressRemainingGasLimit = blockGasLimit
                        , _blockInProgressTransactions = Transactions
                            { _transactionCoinbase = coinbaseOutput
                            , _transactionPairs = mempty
                            }
                        , _blockInProgressMiner = miner
                        , _blockInProgressPactVersion = Pact5T
                        , _blockInProgressChainwebVersion = v
                        , _blockInProgressChainId = cid
                        }
                case fill of
                    NewBlockFill -> ForPact5 <$> Pact5.continueBlock mpAccess blockInProgress
                    NewBlockEmpty -> return (ForPact5 blockInProgress)
            )

execContinueBlock
    :: forall logger tbl pv. (Logger logger, CanReadablePayloadCas tbl)
    => MemPoolAccess
    -> BlockInProgress pv
    -> PactServiceM logger tbl (Historical (BlockInProgress pv))
execContinueBlock mpAccess blockInProgress = pactLabel "execNewBlock" $ do
    Checkpointer.readFrom newBlockParent $
        case _blockInProgressPactVersion blockInProgress of
            -- TODO: after the Pact 5 fork is complete, the Pact 4 case below will
            -- be unnecessary; the genesis blocks are already handled by 'execNewGenesisBlock'.
            Pact4T -> SomeBlockM $ Pair (Pact4.continueBlock mpAccess blockInProgress) (error "pact5")
            Pact5T -> SomeBlockM $ Pair (error "pact4") (Pact5.continueBlock mpAccess blockInProgress)
    where
    newBlockParent = _blockInProgressParentHeader blockInProgress

-- | only for use in generating genesis blocks in tools.
--
execNewGenesisBlock
    :: (Logger logger, CanReadablePayloadCas tbl)
    => Miner
    -> Vector Pact4.UnparsedTransaction
    -> PactServiceM logger tbl PayloadWithOutputs
execNewGenesisBlock miner newTrans = pactLabel "execNewGenesisBlock" $ do
    historicalBlock <- Checkpointer.readFrom Nothing $ SomeBlockM $ Pair
        (do
            logger <- view (psServiceEnv . psLogger)
            v <- view chainwebVersion
            cid <- view chainId
            txs <- liftIO $ traverse (runExceptT . Pact4.checkParse logger v cid (genesisBlockHeight v cid)) newTrans
            parsedTxs <- case partitionEithers (V.toList txs) of
                ([], validTxs) -> return (V.fromList validTxs)
                (errs, _) -> internalError $ "Invalid genesis txs: " <> sshow errs
            -- NEW GENESIS COINBASE: Reject bad coinbase, use date rule for precompilation
            results <-
                Pact4.execTransactions miner parsedTxs
                (Pact4.EnforceCoinbaseFailure True)
                (Pact4.CoinbaseUsePrecompiled False) Nothing Nothing
                >>= throwCommandInvalidError
            return $! toPayloadWithOutputs Pact4T miner results
        )
        (do
            v <- view chainwebVersion
            cid <- view chainId
            let mempoolAccess = mempty
                    { mpaGetBlock = \bf pbc bh bhash _bheader -> do
                        if _bfCount bf == 0
                        then do
                            maybeInvalidTxs <- pbc bh bhash newTrans
                            validTxs <- case partitionEithers (V.toList maybeInvalidTxs) of
                                ([], validTxs) -> return validTxs
                                (errs, _) -> throwM $ Pact5GenesisCommandsInvalid errs
                            V.fromList validTxs `Strategies.usingIO` traverse Strategies.rseq
                        else do
                            return V.empty
                    }
            startHandle <- use Pact5.pbBlockHandle
            let bipStart = BlockInProgress
                    { _blockInProgressHandle = startHandle
                    , _blockInProgressMiner = miner
                    , _blockInProgressModuleCache = Pact5NoModuleCache
                    , _blockInProgressPactVersion = Pact5T
                    , _blockInProgressParentHeader = Nothing
                    , _blockInProgressChainwebVersion = v
                    , _blockInProgressChainId = cid
                    -- fake gas limit, gas is free for genesis
                    , _blockInProgressRemainingGasLimit = GasLimit (Pact4.ParsedInteger 999_999_999)
                    , _blockInProgressTransactions = Transactions
                        { _transactionCoinbase = absurd <$> Pact5.noCoinbase
                        , _transactionPairs = mempty
                        }
                    }
            results <- Pact5.continueBlock mempoolAccess bipStart
            return $! finalizeBlock results
        )
    case historicalBlock of
        NoHistory -> internalError "PactService.execNewGenesisBlock: Impossible error, unable to rewind before genesis"
        Historical block -> return block

execReadOnlyReplay
    :: forall logger tbl
    . (Logger logger, CanReadablePayloadCas tbl)
    => BlockHeader
    -> Maybe BlockHeader
    -> PactServiceM logger tbl ()
execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ do
    ParentHeader cur <- Checkpointer.findLatestValidBlockHeader
    logger <- view psLogger
    bhdb <- view psBlockHeaderDb
    pdb <- view psPdb
    v <- view chainwebVersion
    cid <- view chainId
    -- lower bound must be an ancestor of upper.
    upperBound <- case maybeUpperBound of
        Just upperBound -> do
            liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash upperBound)) >>=
                flip unless (internalError "lower bound is not an ancestor of upper bound")

            -- upper bound must be an ancestor of latest header.
            liftIO (ancestorOf bhdb (view blockHash upperBound) (view blockHash cur)) >>=
                flip unless (internalError "upper bound is not an ancestor of latest header")

            return upperBound
        Nothing -> do
            liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash cur)) >>=
                flip unless (internalError "lower bound is not an ancestor of latest header")

            return cur
    liftIO $ logFunctionText logger Info $ "pact db replaying between blocks "
        <> sshow (view blockHeight lowerBound, view blockHash lowerBound) <> " and "
        <> sshow (view blockHeight upperBound, view blockHash upperBound)

    let genHeight = genesisHeight v cid
    -- we don't want to replay the genesis header in here.
    let lowerHeight = max (succ genHeight) (view blockHeight lowerBound)
    withPactState $ \runPact ->
        liftIO $ getBranchIncreasing bhdb upperBound (int lowerHeight) $ \blocks -> do
            heightRef <- newIORef lowerHeight
            withAsync (heightProgress lowerHeight (view blockHeight upperBound) heightRef (logInfo_ logger)) $ \_ -> do
                blocks
                    & Stream.hoist liftIO
                    & play bhdb pdb heightRef runPact
    where

    play
        :: CanReadablePayloadCas tbl
        => BlockHeaderDb
        -> PayloadDb tbl
        -> IORef BlockHeight
        -> (forall a. PactServiceM logger tbl a -> IO a)
        -> Stream.Stream (Stream.Of BlockHeader) IO r
        -> IO r
    play bhdb pdb heightRef runPact blocks = do
        logger <- runPact $ view psLogger
        validationFailedRef <- newIORef False
        r <- blocks & Stream.mapM_ (\bh -> do
            bhParent <- liftIO $ lookupParentM GenesisParentThrow bhdb bh
            let
                printValidationError (BlockValidationFailure (BlockValidationFailureMsg m)) = do
                    writeIORef validationFailedRef True
                    logFunctionText logger Error m
                printValidationError e = throwM e
                handleMissingBlock NoHistory = throwM $ BlockHeaderLookupFailure $
                    "execReadOnlyReplay: missing block: " <> sshow bh
                handleMissingBlock (Historical ()) = return ()
            payload <- liftIO $ fromJuste <$>
                lookupPayloadWithHeight pdb (Just $ view blockHeight bh) (view blockPayloadHash bh)
            let isPayloadEmpty = V.null (_payloadWithOutputsTransactions payload)
            let isUpgradeBlock = isJust $ _chainwebVersion bhdb ^? versionUpgrades . atChain (_chainId bhdb) . ix (view blockHeight bh)
            liftIO $ writeIORef heightRef (view blockHeight bh)
            unless (isPayloadEmpty && not isUpgradeBlock)
                $ handle printValidationError
                $ (handleMissingBlock =<<)
                $ runPact
                $ Checkpointer.readFrom (Just $ ParentHeader bhParent) $
                    SomeBlockM $ Pair
                        (void $ Pact4.execBlock bh (CheckablePayloadWithOutputs payload))
                        (void $ Pact5.execExistingBlock bh (CheckablePayloadWithOutputs payload))
            )
        validationFailed <- readIORef validationFailedRef
        when validationFailed $
            throwM $ BlockValidationFailure $ BlockValidationFailureMsg "Prior block validation errors"
        return r

    heightProgress :: BlockHeight -> BlockHeight -> IORef BlockHeight -> (Text -> IO ()) -> IO ()
    heightProgress initialHeight endHeight ref logFun = do
        heightAndRateRef <- newIORef (initialHeight, 0.0 :: Double)
        let delayMicros = 20_000_000
        liftIO $ threadDelay (delayMicros `div` 2)
        forever $ do
            liftIO $ threadDelay delayMicros
            (lastHeight, oldRate) <- readIORef heightAndRateRef
            now' <- getCurrentTime
            currentHeight <- readIORef ref
            let blocksPerSecond
                    = 0.8
                        * oldRate
                    + 0.2
                        * fromIntegral (currentHeight - lastHeight)
                        / (fromIntegral delayMicros / 1_000_000)
            writeIORef heightAndRateRef (currentHeight, blocksPerSecond)
            let est =
                    flip addUTCTime now'
                        $ realToFrac @Double @NominalDiffTime
                        $ fromIntegral @BlockHeight @Double
                            (endHeight - initialHeight)
                        / blocksPerSecond
            logFun
                $ Text.pack $ printf "height: %d | rate: %.1f blocks/sec | est. %s"
                        (fromIntegral @BlockHeight @Int $ currentHeight - initialHeight)
                        blocksPerSecond
                        (formatShow iso8601Format est)

execLocal
    :: (Logger logger, CanReadablePayloadCas tbl)
    => Pact4.UnparsedTransaction
    -> Maybe LocalPreflightSimulation
    -- ^ preflight flag
    -> Maybe LocalSignatureVerification
    -- ^ turn off signature verification checks?
    -> Maybe RewindDepth
    -- ^ rewind depth
    -> PactServiceM logger tbl LocalResult
execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do

    e@PactServiceEnv{..} <- ask

    let !cmd = Pact4.payloadObj <$> cwtx
        !pm = Pact4.publicMetaOf cmd
        !v = _chainwebVersion e
        !cid = _chainId e

    bhdb <- view psBlockHeaderDb

    -- when no depth is defined, treat
    -- withCheckpointerRewind as readFrom
    -- (i.e. setting rewind to 0).
    let rewindDepth = maybe 0 _rewindDepth rdepth

    let timeoutLimit
            | _psEnableLocalTimeout = Just (2 * 1_000_000)
            | otherwise = Nothing

    let localPact4 = do
            pc <- view psParentHeader
            let spv = Pact4.pactSPV bhdb (_parentHeader pc)
            ctx <- Pact4.getTxContext noMiner pm
            let bh = Pact4.ctxCurrentBlockHeight ctx
            let gasModel = Pact4.getGasModel ctx
            mc <- Pact4.getInitCache
            dbEnv <- Pact4._cpPactDbEnv <$> view psBlockDbEnv
            logger <- view (psServiceEnv . psLogger)

            evalContT $ withEarlyReturn $ \earlyReturn -> do
                pact4Cwtx <- liftIO (runExceptT (Pact4.checkParse logger v cid bh cwtx)) >>= \case
                    Left err -> earlyReturn $
                        let
                            parseError = Pact4.CommandResult
                                { _crReqKey = Pact4.cmdToRequestKey cmd
                                , _crTxId = Nothing
                                , _crResult = Pact4.PactResult (Left (Pact4.PactError Pact4.SyntaxError Pact4.noInfo [] (sshow err)))
                                , _crGas = cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit . to int
                                , _crLogs = Nothing
                                , _crContinuation = Nothing
                                , _crMetaData = Nothing
                                , _crEvents = []
                                }
                        in case preflight of
                            Just PreflightSimulation -> Pact4LocalResultWithWarns parseError []
                            _ -> Pact4LocalResultLegacy parseError
                    Right pact4Cwtx -> return pact4Cwtx
                case (preflight, sigVerify) of
                    (_, Just NoVerify) -> do
                        let payloadBS = SB.fromShort (Pact4._cmdPayload $ Pact4.payloadBytes <$> cwtx)
                        let validated = Pact4.verifyHash @'Pact4.Blake2b_256 (Pact4._cmdHash cmd) payloadBS
                        case validated of
                            Left err -> earlyReturn $ review _MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err
                            Right _ -> return ()
                    _ -> do
                        let validated = Pact4.assertCommand pact4Cwtx (validPPKSchemes v cid bh) (isWebAuthnPrefixLegal v cid bh)
                        case validated of
                            Left err -> earlyReturn $ review _MetadataValidationFailure (pure $ displayAssertCommandError err)
                            Right () -> return ()

                --
                -- if the ?preflight query parameter is set to True, we run the `applyCmd` workflow
                -- otherwise, we prefer the old (default) behavior. When no preflight flag is
                -- specified, we run the old behavior. When it is set to true, we also do metadata
                -- validations.
                --
                case preflight of
                    Just PreflightSimulation -> do
                        lift (Pact4.liftPactServiceM (Pact4.assertPreflightMetadata cmd ctx sigVerify)) >>= \case
                            Left err -> earlyReturn $ review _MetadataValidationFailure err
                            Right () -> return ()
                        let initialGas = Pact4.initialGasOf $ Pact4._cmdPayload pact4Cwtx
                        T3 cr _mc warns <- liftIO $ Pact4.applyCmd
                            _psVersion _psLogger _psGasLogger Nothing dbEnv
                            noMiner gasModel ctx (TxBlockIdx 0) spv (Pact4.payloadObj <$> pact4Cwtx)
                            initialGas mc ApplyLocal

                        let cr' = hashPact4TxLogs cr
                            warns' = Pact4.renderCompactText <$> toList warns
                        pure $ Pact4LocalResultWithWarns cr' warns'
                    _ -> liftIO $ do
                        let execConfig = Pact4.mkExecutionConfig $
                                [ Pact4.FlagAllowReadInLocal | _psAllowReadsInLocal ] ++
                                Pact4.enablePactEvents' v cid bh ++
                                Pact4.enforceKeysetFormats' v cid bh ++
                                Pact4.disableReturnRTC v cid bh

                        cr <- Pact4.applyLocal
                            _psLogger _psGasLogger dbEnv
                            gasModel ctx spv
                            pact4Cwtx mc execConfig

                        let cr' = hashPact4TxLogs cr
                        pure $ Pact4LocalResultLegacy cr'

    let localPact5 = do
            ph <- view psParentHeader
            let pact5RequestKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx)
            evalContT $ withEarlyReturn $ \earlyReturn -> do
                pact5Cmd <- case Pact5.parsePact4Command cwtx of
                    Left (Left errText) -> do
                        earlyReturn $ Pact5LocalResultLegacy Pact5.CommandResult
                            { _crReqKey = pact5RequestKey
                            , _crTxId = Nothing
                            , _crResult = Pact5.PactResultErr $
                                Pact5.pactErrorToOnChainError $ Pact5.PEParseError
                                    (Pact5.ParsingError $ "pact 4/5 parsing compatibility mismatch: " <> errText)
                                    (Pact5.LineInfo 0)
                            , _crGas = Pact5.Gas $ fromIntegral $ cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit
                            , _crLogs = Nothing
                            , _crContinuation = Nothing
                            , _crMetaData = Nothing
                            , _crEvents = []
                            }
                    Left (Right (fmap Pact5.spanInfoToLineInfo -> parseError)) ->
                        earlyReturn $ Pact5LocalResultLegacy Pact5.CommandResult
                            { _crReqKey = pact5RequestKey
                            , _crTxId = Nothing
                            , _crResult = Pact5.PactResultErr $
                                Pact5.pactErrorToOnChainError parseError
                            , _crGas = Pact5.Gas $ fromIntegral $ cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit
                            , _crLogs = Nothing
                            , _crContinuation = Nothing
                            , _crMetaData = Nothing
                            , _crEvents = []
                            }
                    Right pact5Cmd -> return pact5Cmd

                -- this is just one of our metadata validation passes.
                -- in preflight, we do another one, which replicates some of this work;
                -- TODO: unify preflight, newblock, and validateblock tx metadata validation
                case (preflight, sigVerify) of
                    (_, Just NoVerify) -> do
                        let payloadBS = SB.fromShort (Pact4._cmdPayload $ Pact4.payloadBytes <$> cwtx)
                        let validated = Pact5.verifyHash (Pact5._cmdHash pact5Cmd) payloadBS
                        case validated of
                            Left err -> earlyReturn $
                                review _MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err
                            Right _ -> return ()
                    _ -> do
                        let validated = Pact5.assertCommand pact5Cmd
                        case validated of
                            Left err -> earlyReturn $
                                review _MetadataValidationFailure (pure $ displayAssertCommandError err)
                            Right () -> return ()

                let txCtx = Pact5.TxContext ph noMiner
                let spvSupport = Pact5.pactSPV bhdb (_parentHeader ph)
                case preflight of
                    Just PreflightSimulation -> do
                        -- preflight needs to do additional checks on the metadata
                        -- to match on-chain tx validation
                        lift (Pact5.liftPactServiceM (Pact5.assertPreflightMetadata (view Pact5.payloadObj <$> pact5Cmd) txCtx sigVerify)) >>= \case
                            Left err -> earlyReturn $ review _MetadataValidationFailure err
                            Right () -> return ()
                        let initialGas = Pact5.initialGasOf v cid (Pact5.ctxCurrentBlockHeight txCtx) (Pact5.ctxParentForkNumber txCtx) pact5Cmd
                        applyCmdResult <- lift $ Pact5.pactTransaction Nothing (\dbEnv ->
                            Pact5.applyCmd
                                _psLogger _psGasLogger dbEnv
                                txCtx (TxBlockIdx 0) spvSupport initialGas (view Pact5.payloadObj <$> pact5Cmd)
                                )
                        commandResult <- case applyCmdResult of
                            Left err ->
                                earlyReturn $ Pact5LocalResultWithWarns Pact5.CommandResult
                                    { _crReqKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx)
                                    , _crTxId = Nothing
                                    , _crResult = Pact5.PactResultErr $
                                        Pact5.PactOnChainError
                                            -- the only legal error type, once chainweaver is really gone, we
                                            -- can use a real error type
                                            (Pact5.ErrorType "EvalError")
                                            (Pact5.mkBoundedText $ prettyPact5GasPurchaseFailure err)
                                            (Pact5.LocatedErrorInfo Pact5.TopLevelErrorOrigin Pact5.noInfo)
                                    , _crGas = Pact5.Gas $ fromIntegral $ cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit
                                    , _crLogs = Nothing
                                    , _crContinuation = Nothing
                                    , _crMetaData = Nothing
                                    , _crEvents = []
                                    }
                                    []
                            Right commandResult -> return commandResult
                        let pact5Pm = pact5Cmd ^. Pact5.cmdPayload . Pact5.payloadObj . Pact5.pMeta
                        let metadata = J.toJsonViaEncode $ Pact5.StableEncoding $ Pact5.ctxToPublicData pact5Pm txCtx
                        let commandResult' = hashPact5TxLogs $ set Pact5.crMetaData (Just metadata) commandResult
                        -- TODO: once Pact 5 has warnings, include them here.
                        pure $ Pact5LocalResultWithWarns
                            (Pact5.pactErrorToOnChainError <$> commandResult')
                            []
                    _ -> lift $ do
                        -- default is legacy mode: use applyLocal, don't buy gas, don't do any
                        -- metadata checks beyond signature and hash checking
                        cr <- Pact5.pactTransaction Nothing $ \dbEnv -> do
                            fmap Pact5.pactErrorToOnChainError <$> Pact5.applyLocal _psLogger _psGasLogger dbEnv txCtx spvSupport (view Pact5.payloadObj <$> pact5Cmd)
                        pure $ Pact5LocalResultLegacy (hashPact5TxLogs cr)

    let doLocal = Checkpointer.readFromNthParent (fromIntegral rewindDepth)
            $ SomeBlockM $ Pair localPact4 localPact5

    case timeoutLimit of
        Nothing -> doLocal
        Just limit -> withPactState $ \run -> timeoutYield limit (run doLocal) >>= \case
            Just r -> pure r
            Nothing -> do
                logError_ _psLogger $ "Local action timed out for cwtx:\n" <> sshow cwtx
                pure $ review _LocalTimeout ()

execSyncToBlock
    :: (CanReadablePayloadCas tbl, Logger logger)
    => BlockHeader
    -> PactServiceM logger tbl ()
execSyncToBlock targetHeader = pactLabel "execSyncToBlock" $ do
    latestHeader <- Checkpointer.findLatestValidBlockHeader' >>= maybe failNonGenesisOnEmptyDb return
    if latestHeader == targetHeader
    then do
        logInfoPact $ "checkpointer at checkpointer target"
            <> ". target height: " <> sshow (view blockHeight latestHeader)
            <> "; target hash: " <> blockHashToText (view blockHash latestHeader)
    else do
        logInfoPact $ "rewind to checkpointer target"
                <> ". current height: " <> sshow (view blockHeight latestHeader)
                <> "; current hash: " <> blockHashToText (view blockHash latestHeader)
                <> "; target height: " <> sshow targetHeight
                <> "; target hash: " <> blockHashToText targetHash
        Checkpointer.rewindToIncremental Nothing (ParentHeader targetHeader)
    where
    targetHeight = view blockHeight targetHeader
    targetHash = view blockHash targetHeader
    failNonGenesisOnEmptyDb = error "impossible: playing non-genesis block to empty DB"

-- | Validate a mined block `(headerToValidate, payloadToValidate).
-- Note: The BlockHeader here is the header of the block being validated.
-- To do this, we atomically:
-- - determine if the block is on a different fork from the checkpointer's
--   current latest block, and execute all of the blocks on that fork if so,
--   all the way to the parent of the block we're validating.
-- - run the Pact transactions in the block.
-- - commit the result to the database.
--
execValidateBlock
    :: (CanReadablePayloadCas tbl, Logger logger)
    => MemPoolAccess
    -> BlockHeader
    -> CheckablePayload
    -> PactServiceM logger tbl (PayloadWithOutputs, Pact4.Gas)
execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel "execValidateBlock" $ do
    bhdb <- view psBlockHeaderDb
    payloadDb <- view psPdb
    v <- view chainwebVersion
    cid <- view chainId
    RewindLimit reorgLimit <- view psReorgLimit

    -- The parent block header must be available in the block header database.
    parentOfHeaderToValidate <- getTarget

    -- Add block-hash to the logs if presented
    let logBlockHash =
            localLabelPact ("block-hash", blockHashToText (view blockParent headerToValidate))

    logBlockHash $ do
        currHeader <- Checkpointer.findLatestValidBlockHeader'
        -- find the common ancestor of the new block and our current block
        commonAncestor <- liftIO $ case (currHeader, parentOfHeaderToValidate) of
            (Just currHeader', Just ph) ->
                Just <$> forkEntry bhdb currHeader' (_parentHeader ph)
            _ ->
                return Nothing
        -- check that we don't exceed the rewind limit. for the purpose
        -- of this check, the genesis block and the genesis parent
        -- have the same height.
        let !currHeight = maybe (genesisHeight v cid) (view blockHeight) currHeader
        let !ancestorHeight = maybe (genesisHeight v cid) (view blockHeight) commonAncestor
        let !rewindLimitSatisfied = ancestorHeight + fromIntegral reorgLimit >= currHeight
        unless rewindLimitSatisfied $
            throwM $ RewindLimitExceeded
                (RewindLimit reorgLimit)
                currHeader
                commonAncestor
        -- get all blocks on the fork we're going to play, up to the parent
        -- of the block we're validating
        let withForkBlockStream kont = case parentOfHeaderToValidate of
                Nothing ->
                    -- we're validating a genesis block, so there are no fork blocks to speak of.
                    kont (pure ())
                Just (ParentHeader parentHeaderOfHeaderToValidate) ->
                    let forkStartHeight = maybe (genesisHeight v cid) (succ . view blockHeight) commonAncestor
                    in getBranchIncreasing bhdb parentHeaderOfHeaderToValidate (fromIntegral forkStartHeight) kont

        ((), results) <-
            withPactState $ \runPact ->
                withForkBlockStream $ \forkBlockHeaders -> do

                    -- given a header for a block in the fork, fetch its payload
                    -- and run its transactions, validating its hashes
                    let runForkBlockHeaders = forkBlockHeaders & Stream.map (\forkBh -> do
                            payload <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ view blockHeight forkBh) (view blockPayloadHash forkBh) >>= \case
                                Nothing -> internalError
                                    $ "execValidateBlock: lookup of payload failed"
                                    <> ". BlockPayloadHash: " <> encodeToText (view blockPayloadHash forkBh)
                                    <> ". Block: " <> encodeToText (ObjectEncoded forkBh)
                                Just x -> return $ payloadWithOutputsToPayloadData x
                            SomeBlockM $ Pair
                                (void $ Pact4.execBlock forkBh (CheckablePayload payload))
                                (void $ Pact5.execExistingBlock forkBh (CheckablePayload payload))
                            return ([], forkBh)
                            )

                    -- run the new block, the one we're validating, and
                    -- validate its hashes
                    let runThisBlock = Stream.yield $ SomeBlockM $ Pair
                            (do
                                !output <- Pact4.execBlock headerToValidate payloadToValidate
                                return ([output], headerToValidate)
                            )
                            (do
                                !(gas, pwo) <- Pact5.execExistingBlock headerToValidate payloadToValidate
                                return ([(fromIntegral (Pact5._gas gas), pwo)], headerToValidate)
                            )

                    -- here we rewind to the common ancestor block, run the
                    -- transactions in all of its child blocks until the parent
                    -- of the block we're validating, then run the block we're
                    -- validating.
                    runPact $ Checkpointer.restoreAndSave
                        (ParentHeader <$> commonAncestor)
                        (runForkBlockHeaders >> runThisBlock)
        let logRewind =
                -- we consider a fork of height more than 3 to be notable.
                if ancestorHeight + 3 < currHeight
                then logWarnPact
                else logDebugPact
        logRewind $
            "execValidateBlock: rewound " <> sshow (currHeight - ancestorHeight) <> " blocks"
        (totalGasUsed, result) <- case results of
            [r] -> return r
            _ -> internalError "execValidateBlock: wrong number of block results returned from _cpRestoreAndSave."

        -- update mempool
        --
        -- Using the parent isn't optimal, since it doesn't delete the txs of
        -- `currHeader` from the set of pending tx. The reason for this is that the
        -- implementation 'mpaProcessFork' uses the chain database and at this point
        -- 'currHeader' is generally not yet available in the database. It would be
        -- possible to extract the txs from the result and remove them from the set
        -- of pending txs. However, that would add extra complexity and at little
        -- gain.
        --
        case parentOfHeaderToValidate of
            Nothing -> return ()
            Just (ParentHeader p) -> liftIO $ do
                mpaProcessFork memPoolAccess p
                mpaSetLastHeader memPoolAccess p

        return (result, totalGasUsed)

    where
    getTarget
        | isGenesisBlockHeader headerToValidate = return Nothing
        | otherwise = Just . ParentHeader
            <$> lookupBlockHeader (view blockParent headerToValidate) "execValidateBlock"
                -- It is up to the user of pact service to guaranteed that this
                -- succeeds. If this fails it usually means that the block
                -- header database is corrupted.

execBlockTxHistory
    :: Logger logger
    => BlockHeader
    -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info
    -> PactServiceM logger tbl (Historical BlockTxHistory)
execBlockTxHistory bh d =
    pactLabel "execBlockTxHistory" $ Checkpointer.getBlockHistory bh d

execHistoricalLookup
    :: Logger logger
    => BlockHeader
    -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info
    -> Pact5.RowKey
    -> PactServiceM logger tbl (Historical (Maybe (Pact5.TxLog Pact5.RowData)))
execHistoricalLookup bh d k =
    pactLabel "execHistoricalLookup" $ Checkpointer.lookupHistorical bh d k

execPreInsertCheckReq
    :: (CanReadablePayloadCas tbl, Logger logger)
    => Vector Pact4.UnparsedTransaction
    -> PactServiceM logger tbl (Vector (Maybe Mempool.InsertError))
execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do
    let requestKeys = V.map Pact4.cmdToRequestKey txs
    logInfoPact $ "(request keys = " <> sshow requestKeys <> ")"
    psEnv <- ask
    psState <- get
    logger <- view psLogger
    let timeoutLimit = fromIntegral $ (\(Micros n) -> n) $ _psPreInsertCheckTimeout psEnv
    let act = Checkpointer.readFromLatest $ SomeBlockM $ Pair
            (do
                pdb <- view psBlockDbEnv
                pc <- view psParentHeader
                let
                    parentTime = ParentCreationTime (view blockCreationTime $ _parentHeader pc)
                    currHeight = succ $ view blockHeight $ _parentHeader pc
                    v = _chainwebVersion pc
                    cid = _chainId pc
                liftIO $ forM txs $ \tx -> do
                    let isGenesis = False
                    fmap (either Just (\_ -> Nothing)) $ runExceptT $ do
                        parsedTx <- Pact4.validateRawChainwebTx
                            logger v cid pdb parentTime currHeight tx
                        ExceptT $ evalPactServiceM psState psEnv . Pact4.runPactBlockM pc isGenesis pdb
                            $ attemptBuyGasPact4 noMiner parsedTx
                        return parsedTx
            )
            (do
                db <- view psBlockDbEnv
                ph <- view psParentHeader
                v <- view chainwebVersion
                cid <- view chainId
                initialBlockHandle <- use Pact5.pbBlockHandle
                let
                    parentTime = ParentCreationTime (view blockCreationTime $ _parentHeader ph)
                    currHeight = succ $ view blockHeight $ _parentHeader ph
                    isGenesis = False
                forM txs $ \tx ->
                    fmap (either Just (\_ -> Nothing)) $ runExceptT $ do
                        -- it's safe to use initialBlockHandle here because it's
                        -- only used to check for duplicate pending txs in a block
                        pact5Tx <- mapExceptT liftIO $ Pact5.validateRawChainwebTx
                            logger v cid db initialBlockHandle parentTime currHeight isGenesis tx
                        let logger' = addLabel ("transaction", "attemptBuyGas") logger
                        ExceptT $ Pact5.pactTransaction Nothing $ \pactDb -> runExceptT $ do
                            let txCtx = Pact5.TxContext ph noMiner
                            -- Note: `mempty` is fine here for the milligas limit. `buyGas` sets its own limit
                            -- by necessity
                            gasEnv <- liftIO $ Pact5.mkTableGasEnv (Pact5.MilliGasLimit mempty) Pact5.GasLogsDisabled
                            liftIO (Pact5.buyGas logger' gasEnv pactDb txCtx (view Pact5.payloadObj <$> pact5Tx)) >>= \case
                                Left err -> do
                                    throwError $ InsertErrorBuyGas $ prettyPact5GasPurchaseFailure $ BuyGasError (Pact5.cmdToRequestKey pact5Tx) err
                                Right (_ :: Pact5.EvalResult) -> return ()

                            -- check if the continuation is continuing a defpact that has already finished
                            case pact5Tx ^? Pact5.cmdPayload . Pact5.payloadObj . Pact5.pPayload . Pact5._Continuation of
                                Just contMsg -> do
                                    let pactId = Pact5._cmPactId contMsg
                                    defPactState <- liftIO $ Pact5.ignoreGas (Pact5.LineInfo 0) $ Pact5._pdbRead pactDb Pact5.DDefPacts pactId
                                    let isComplete = defPactState == Just Nothing
                                    when isComplete $
                                        throwError (InsertErrorDefPactComplete (sshow pactId))
                                Nothing -> return ()
            )
    withPactState $ \run ->
        timeoutYield timeoutLimit (run act) >>= \case
            Just r -> do
                logDebug_ logger $ "Mempool pre-insert check result: " <> sshow r
                pure r
            Nothing -> do
                logError_ logger $ "Mempool pre-insert check timed out for txs:\n" <> sshow txs
                let result = V.map (const $ Just Mempool.InsertErrorTimedOut) txs
                logDebug_ logger $ "Mempool pre-insert check result: " <> sshow result
                pure result

    where
    attemptBuyGasPact4
        :: forall logger tbl. (Logger logger)
        => Miner
        -> Pact4.Transaction
        -> Pact4.PactBlockM logger tbl (Either InsertError ())
    attemptBuyGasPact4 miner tx = Pact4.localLabelBlock ("transaction", "attemptBuyGas") $ do
            mcache <- Pact4.getInitCache
            l <- view (psServiceEnv . psLogger)
            do
                let cmd = Pact4.payloadObj <$> tx
                    gasPrice = view Pact4.cmdGasPrice cmd
                    gasLimit = fromIntegral $ view Pact4.cmdGasLimit cmd
                    txst = Pact4.TransactionState
                        { _txCache = mcache
                        , _txLogs = mempty
                        , _txGasUsed = 0
                        , _txGasId = Nothing
                        , _txGasModel = Pact4._geGasModel Pact4.freeGasEnv
                        , _txWarnings = mempty
                        }
                let !nid = Pact4.networkIdOf cmd
                let !rk = Pact4.cmdToRequestKey cmd
                pd <- Pact4.getTxContext miner (Pact4.publicMetaOf cmd)
                bhdb <- view (psServiceEnv . psBlockHeaderDb)
                dbEnv <- Pact4._cpPactDbEnv <$> view psBlockDbEnv
                spv <- Pact4.pactSPV bhdb . _parentHeader <$> view psParentHeader
                let ec = Pact4.mkExecutionConfig $
                        [ Pact4.FlagDisableModuleInstall
                        , Pact4.FlagDisableHistoryInTransactionalMode ] ++
                        Pact4.disableReturnRTC (Pact4.ctxVersion pd) (Pact4.ctxChainId pd) (Pact4.ctxCurrentBlockHeight pd)
                let buyGasEnv = Pact4.TransactionEnv Pact4.Transactional dbEnv l Nothing (Pact4.ctxToPublicData pd) spv nid gasPrice rk gasLimit ec Nothing Nothing

                cr <- liftIO
                    $! Pact4.catchesPactError l Pact4.CensorsUnexpectedError
                    $! Pact4.execTransactionM buyGasEnv txst
                    $! Pact4.buyGas pd cmd miner

                return $ bimap (InsertErrorBuyGas . sshow) (\_ -> ()) cr


execLookupPactTxs
    :: (CanReadablePayloadCas tbl, Logger logger)
    => Maybe ConfirmationDepth
    -> Vector SB.ShortByteString
    -> PactServiceM logger tbl (HM.HashMap SB.ShortByteString (T2 BlockHeight BlockHash))
execLookupPactTxs confDepth txs = pactLabel "execLookupPactTxs" $ do
    if V.null txs then return mempty else go
    where
    go = Checkpointer.readFromNthParent (maybe 0 (fromIntegral . _confirmationDepth) confDepth) $
        SomeBlockM $ Pair
        (do
            dbenv <- view psBlockDbEnv
            fmap (HM.mapKeys coerce) $ liftIO $ Pact4._cpLookupProcessedTx dbenv (coerce txs)
        )
        (do
            dbenv <- view psBlockDbEnv
            fmap (HM.mapKeys coerce) $ liftIO $ Pact5.lookupPactTransactions dbenv (coerce txs)
        )

pactLabel :: (Logger logger) => Text -> PactServiceM logger tbl x -> PactServiceM logger tbl x
pactLabel lbl x = localLabelPact ("pact-request", lbl) x