ExecBlock.hs

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

-- |
-- Module: Chainweb.Pact.PactService.Pact4.ExecBlock
-- Copyright: Copyright © 2020 Kadena LLC.
-- License: See LICENSE file
-- Maintainers: Lars Kuhtz, Emily Pillmore, Stuart Popejoy
-- Stability: experimental
--
-- Functionality for playing block transactions.
--
module Chainweb.Pact.PactService.Pact4.ExecBlock
    ( execBlock
    , execTransactions
    , continueBlock
    , toPayloadWithOutputs
    , validateParsedChainwebTx
    , validateRawChainwebTx
    , validateHashes
    , throwCommandInvalidError
    , initModuleCacheForBlock
    , runCoinbase
    , CommandInvalidError(..)
    , checkParse
    ) where

import Chronos qualified
import Control.Concurrent.MVar
import Control.DeepSeq
import Control.Exception (evaluate)
import Control.Lens
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.State.Strict

import System.LogLevel (LogLevel(..))
import qualified Data.ByteString.Short as SB
import Data.List qualified as List
import Data.Either
import Data.Foldable (toList)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V

import System.IO
import System.Timeout

import Prelude hiding (lookup)

import Pact.Compile (compileExps)
import Pact.Interpreter(PactDbEnv(..))
import qualified Pact.JSON.Encode as J
import qualified Pact.Parse as Pact4 hiding (parsePact)
import qualified Pact.Types.Command as Pact4
import Pact.Types.ExpParser (mkTextInfo, ParseEnv(..))
import qualified Pact.Types.Hash as Pact4
import Pact.Types.RPC
import qualified Pact.Types.Runtime as Pact4
import qualified Pact.Types.SPV as Pact4

import Chainweb.BlockHeader
import Chainweb.BlockHeight
import Chainweb.Logger
import Chainweb.Mempool.Mempool as Mempool
import Chainweb.MinerReward
import Chainweb.Miner.Pact

import Chainweb.Pact.Types
import Chainweb.Pact4.SPV qualified as Pact4
import Chainweb.Pact4.NoCoinbase
import qualified Chainweb.Pact4.Transaction as Pact4
import qualified Chainweb.Pact4.TransactionExec as Pact4
import qualified Chainweb.Pact4.Validations as Pact4
import Chainweb.Payload
import Chainweb.Payload.PayloadStore
import Chainweb.Time
import Chainweb.Utils hiding (check)
import Chainweb.Version
import Chainweb.ForkState (pact4ForkNumber)
import Chainweb.Version.Guards
import Chainweb.Pact4.Backend.ChainwebPactDb
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
import Chainweb.Pact4.Types
import Chainweb.Pact4.ModuleCache
import Control.Monad.Except
import qualified Data.List.NonEmpty as NE
import Chainweb.Pact.Backend.Types (BlockHandle(..))


-- | Execute a block -- only called in validate either for replay or for validating current block.
--
execBlock
    :: (CanReadablePayloadCas tbl, Logger logger)
    => BlockHeader
        -- ^ this is the current header. We may consider changing this to the parent
        -- header to avoid confusion with new block and prevent using data from this
        -- header when we should use the respective values from the parent header
        -- instead.
    -> CheckablePayload
    -> PactBlockM logger tbl (Pact4.Gas, PayloadWithOutputs)
execBlock currHeader payload = do
    let plData = checkablePayloadToPayloadData payload
    dbEnv <- view psBlockDbEnv
    miner <- decodeStrictOrThrow' (_minerData $ view payloadDataMiner plData)

    trans <- liftIO $ pact4TransactionsFromPayload
      (pact4ParserVersion v (_chainId currHeader) (view blockHeight currHeader))
      plData
    logger <- view (psServiceEnv . psLogger)

    -- The reference time for tx timings validation.
    --
    -- The legacy behavior is to use the creation time of the /current/ header.
    -- The new default behavior is to use the creation time of the /parent/ header.
    --
    txValidationTime <- if isGenesisBlockHeader currHeader
      then return (ParentCreationTime $ view blockCreationTime currHeader)
      else ParentCreationTime . view blockCreationTime . _parentHeader <$> view psParentHeader

    -- prop_tx_ttl_validate
    errorsIfPresent <- liftIO $
        forM (V.toList trans) $ \tx ->
          fmap (Pact4._cmdHash tx,) $
            runExceptT $
              validateParsedChainwebTx logger v cid dbEnv txValidationTime
                (view blockHeight currHeader) tx

    case NE.nonEmpty [ (hsh, sshow err) | (hsh, Left err) <- errorsIfPresent ] of
      Nothing -> return ()
      Just errs -> throwM $ Pact4TransactionValidationException errs

    logInitCache

    !results <- go miner trans >>= throwCommandInvalidError

    let !totalGasUsed = sumOf (folded . to Pact4._crGas) results

    pwo <- either throwM return $
      validateHashes currHeader payload miner results
    return (totalGasUsed, pwo)
  where
    blockGasLimit =
      fromIntegral <$> maxBlockGasLimit v pact4ForkNumber (view blockHeight currHeader)

    logInitCache = liftPactServiceM $ do
      mc <- fmap (fmap instr . _getModuleCache) <$> use psInitCache
      logDebugPact $ "execBlock: initCache: " <> sshow mc

    instr (md,_) = preview (Pact4._MDModule . Pact4.mHash) $ Pact4._mdModule md

    v = _chainwebVersion currHeader
    cid = _chainId currHeader

    isGenesisBlock = isGenesisBlockHeader currHeader

    go m txs = if isGenesisBlock
      then
        -- GENESIS VALIDATE COINBASE: Reject bad coinbase, use date rule for precompilation
        execTransactions m txs
          (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled False) blockGasLimit Nothing
      else
        -- VALIDATE COINBASE: back-compat allow failures, use date rule for precompilation
        execTransactions m txs
          (EnforceCoinbaseFailure False) (CoinbaseUsePrecompiled False) blockGasLimit Nothing

throwCommandInvalidError
    :: Transactions Pact4 (Either CommandInvalidError a)
    -> PactBlockM logger tbl (Transactions Pact4 a)
throwCommandInvalidError = (transactionPairs . traverse . _2) throwGasFailure
  where
    throwGasFailure = \case
      Left (CommandInvalidGasPurchaseFailure e) -> throwM (Pact4BuyGasFailure e)

      -- this should be impossible because we don't
      -- set tx time limits in validateBlock
      Left (CommandInvalidTxTimeout t) -> throwM t

      Right r -> pure r

-- | The validation logic for Pact Transactions that have not had their
-- code parsed yet. This is used by the mempool to estimate tx validity
-- before inclusion into blocks, but it's also used by ExecBlock to check
-- if all of the txs in a block are valid.
--
-- Skips validation for genesis transactions, since gas accounts, etc. don't
-- exist yet.
--
validateRawChainwebTx
    :: forall logger
    . (Logger logger)
    => logger
    -> ChainwebVersion
    -> ChainId
    -> PactDbFor logger Pact4
    -> ParentCreationTime
        -- ^ reference time for tx validation.
    -> BlockHeight
        -- ^ Current block height
    -> Pact4.UnparsedTransaction
    -> ExceptT InsertError IO Pact4.Transaction
validateRawChainwebTx logger v cid dbEnv txValidationTime bh tx = do
  parsed <- checkParse logger v cid bh tx
  validateParsedChainwebTx logger v cid dbEnv txValidationTime bh parsed
  return parsed

-- | The principal validation logic for groups of Pact Transactions.
-- This is used by the mempool to estimate tx validity
-- before inclusion into blocks, but it's also used by ExecBlock to check
-- if all of the txs in a block are valid.
--
-- Skips validation for genesis transactions, since gas accounts, etc. don't
-- exist yet.
--
validateParsedChainwebTx
    :: Logger logger
    => logger
    -> ChainwebVersion
    -> ChainId
    -> PactDbFor logger Pact4
    -> ParentCreationTime
        -- ^ reference time for tx validation.
    -> BlockHeight
        -- ^ Current block height
    -> Pact4.Transaction
    -> ExceptT InsertError IO ()
validateParsedChainwebTx logger v cid dbEnv txValidationTime bh tx
  | bh == genesisHeight v cid = pure ()
  | otherwise = do
      checkUnique logger dbEnv tx
      checkTxHash logger v cid bh tx
      checkChain cid tx
      checkTxSigs logger v cid bh tx
      checkTimes logger v cid bh txValidationTime tx
      _ <- checkCompile logger v cid bh tx
      return ()

checkChain
  :: ChainId -> Pact4.Transaction -> ExceptT InsertError IO ()
checkChain cid tx =
  unless (Pact4.assertChainId cid txCid) $
    throwError $ InsertErrorWrongChain (chainIdToText cid) (Pact4._chainId txCid)
  where
  txCid = view (Pact4.cmdPayload . to Pact4.payloadObj . Pact4.pMeta . Pact4.pmChainId) tx

checkUnique
  :: (Logger logger)
  => logger
  -> PactDbFor logger Pact4
  -> Pact4.Command (Pact4.PayloadWithText meta code)
  -> ExceptT InsertError IO ()
checkUnique logger dbEnv t = do
  liftIO $ logFunctionText logger Debug $ "Pact4.checkUnique: " <> sshow (Pact4._cmdHash t)
  found <- liftIO $
    HashMap.lookup (coerce $ Pact4.toUntypedHash $ Pact4._cmdHash t) <$>
      _cpLookupProcessedTx dbEnv
        (V.singleton $ coerce $ Pact4.toUntypedHash $ Pact4._cmdHash t)
  case found of
    Nothing -> pure ()
    Just _ -> throwError InsertErrorDuplicate

checkTimes
  :: (Logger logger)
  => logger
  -> ChainwebVersion
  -> ChainId
  -> BlockHeight
  -> ParentCreationTime
  -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta code)
  -> ExceptT InsertError IO ()
checkTimes logger v cid bh txValidationTime t = do
    liftIO $ logFunctionText logger Debug $ "Pact4.checkTimes: " <> sshow (Pact4._cmdHash t)
    if | skipTxTimingValidation v cid bh ->
           return ()
       | not (Pact4.assertTxNotInFuture txValidationTime (Pact4.payloadObj <$> t)) ->
           throwError InsertErrorTimeInFuture
       | not (Pact4.assertTxTimeRelativeToParent txValidationTime (Pact4.payloadObj <$> t)) ->
           throwError InsertErrorTTLExpired
       | otherwise ->
           return ()

checkTxHash
  :: (Logger logger)
  => logger
  -> ChainwebVersion
  -> ChainId
  -> BlockHeight
  -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta code)
  -> ExceptT InsertError IO ()
checkTxHash logger v cid bh t = do
    liftIO $ logFunctionText logger Debug $ "Pact4.checkTxHash: " <> sshow (Pact4._cmdHash t)
    case Pact4.verifyHash (Pact4._cmdHash t) (SB.fromShort $ Pact4.payloadBytes $ Pact4._cmdPayload t) of
        Left _
            | doCheckTxHash v cid bh -> throwError InsertErrorInvalidHash
            | otherwise -> pure ()
        Right _ -> pure ()

checkTxSigs
  :: (MonadIO f, MonadError InsertError f, Logger logger)
  => logger
  -> ChainwebVersion
  -> ChainId
  -> BlockHeight
  -> Pact4.Command (Pact4.PayloadWithText m c)
  -> f ()
checkTxSigs logger v cid bh t = do
  liftIO $ logFunctionText logger Debug $ "Pact4.checkTxSigs: " <> sshow (Pact4._cmdHash t)
  case Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs of
      Right _ -> do
          pure ()
      Left err -> do
        throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err)
  where
    hsh = Pact4._cmdHash t
    sigs = Pact4._cmdSigs t
    signers = Pact4._pSigners $ Pact4.payloadObj $ Pact4._cmdPayload t
    validSchemes = validPPKSchemes v cid pact4ForkNumber bh
    webAuthnPrefixLegal = isWebAuthnPrefixLegal v cid bh

checkCompile
  :: (Logger logger)
  => logger
  -> ChainwebVersion
  -> ChainId
  -> BlockHeight
  -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta Pact4.ParsedCode)
  -> ExceptT InsertError IO Pact4.Transaction
checkCompile logger v cid bh tx = do
  liftIO $ logFunctionText logger Debug $ "Pact4.checkCompile: " <> sshow (Pact4._cmdHash tx)
  case payload of
    Exec (ExecMsg parsedCode _) ->
      case compileCode parsedCode of
        Left perr -> throwError $ InsertErrorCompilationFailed (sshow perr)
        Right _ -> return tx
    _ -> return tx
  where
    payload = Pact4._pPayload $ Pact4.payloadObj $ Pact4._cmdPayload tx
    compileCode p =
      let e = ParseEnv (chainweb216Pact v cid bh)
      in compileExps e (mkTextInfo (Pact4._pcCode p)) (Pact4._pcExps p)

checkParse
  :: (Logger logger)
  => logger
  -> ChainwebVersion
  -> ChainId
  -> BlockHeight
  -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta Text)
  -> ExceptT InsertError IO Pact4.Transaction
checkParse logger v cid bh tx = do
  liftIO $ logFunctionText logger Debug $ "Pact4.checkParse: " <> sshow (Pact4._cmdHash tx)
  forMOf (traversed . traversed) tx
    (either (throwError . InsertErrorPactParseError . T.pack) return . Pact4.parsePact (pact4ParserVersion v cid bh))

execTransactions
    :: (Logger logger)
    => Miner
    -> Vector Pact4.Transaction
    -> EnforceCoinbaseFailure
    -> CoinbaseUsePrecompiled
    -> Maybe Pact4.Gas
    -> Maybe Micros
    -> PactBlockM logger tbl (Transactions Pact4 (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])))
execTransactions miner ctxs enfCBFail usePrecomp gasLimit timeLimit = do
    mc <- initModuleCacheForBlock
    -- for legacy reasons (ask Emily) we don't use the module cache resulting
    -- from coinbase to run the pact cmds
    coinOut <- runCoinbase miner enfCBFail usePrecomp mc
    T2 txOuts _mcOut <- applyPactCmds ctxs miner mc gasLimit timeLimit
    return $! Transactions (V.zip ctxs txOuts) coinOut

initModuleCacheForBlock :: (Logger logger) => PactBlockM logger tbl ModuleCache
initModuleCacheForBlock = do
  PactServiceState{..} <- get
  isGenesis <- view psIsGenesis
  pbh <- views psParentHeader (view blockHeight . _parentHeader)
  case Map.lookupLE pbh _psInitCache of
    Nothing -> if isGenesis
      then return mempty
      else do
        mc <- Pact4.readInitModules
        updateInitCacheM mc
        return mc
    Just (_,mc) -> pure mc

runCoinbase
    :: (Logger logger)
    => Miner
    -> EnforceCoinbaseFailure
    -> CoinbaseUsePrecompiled
    -> ModuleCache
    -> PactBlockM logger tbl (Pact4.CommandResult [Pact4.TxLogJson])
runCoinbase miner enfCBFail usePrecomp mc = do
    isGenesis <- view psIsGenesis
    if isGenesis
    then return noCoinbase
    else do
      logger <- view (psServiceEnv . psLogger)
      v <- view chainwebVersion
      txCtx <- getTxContext miner Pact4.noPublicMeta

      let !bh = ctxCurrentBlockHeight txCtx

      let reward = minerReward v bh
      dbEnv <- view psBlockDbEnv
      let pactDb = _cpPactDbEnv dbEnv

      T2 cr upgradedCacheM <-
          liftIO $ Pact4.applyCoinbase v logger pactDb reward txCtx enfCBFail usePrecomp mc
      mapM_ upgradeInitCache upgradedCacheM
      liftPactServiceM $ debugResult "runPact4Coinbase" (Pact4.crLogs %~ fmap J.Array $ cr)
      return $! cr

  where
    upgradeInitCache newCache = do
      liftPactServiceM $ logInfoPact "Updating init cache for upgrade"
      updateInitCacheM newCache


data CommandInvalidError
  = CommandInvalidGasPurchaseFailure !Pact4GasPurchaseFailure
  | CommandInvalidTxTimeout !TxTimeout

-- | Apply multiple Pact commands, incrementing the transaction Id for each.
-- The output vector is in the same order as the input (i.e. you can zip it
-- with the inputs.)
applyPactCmds
    :: forall logger tbl. (Logger logger)
    => Vector Pact4.Transaction
    -> Miner
    -> ModuleCache
    -> Maybe Pact4.Gas
    -> Maybe Micros
    -> PactBlockM logger tbl (T2 (Vector (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson]))) ModuleCache)
applyPactCmds cmds miner startModuleCache blockGas txTimeLimit = do
    let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to Pact4._crGas) txs
    (txOuts, T2 mcOut _) <- tracePactBlockM' "applyPactCmds" (\_ -> ()) (txsGas . fst) $
      flip runStateT (T2 startModuleCache blockGas) $
        go [] (zip [0..] $ V.toList cmds)
    return $! T2 (V.fromList . List.reverse $ txOuts) mcOut
  where
    go
      :: [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])]
      -> [(Word, Pact4.Transaction)]
      -> StateT
          (T2 ModuleCache (Maybe Pact4.Gas))
          (PactBlockM logger tbl)
          [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])]
    go !acc = \case
        [] -> do
            pure acc
        (txIdxInBlock, tx) : rest -> do
            r <- applyPactCmd (TxBlockIdx txIdxInBlock) miner txTimeLimit tx
            case r of
                Left e@(CommandInvalidTxTimeout _) -> do
                    pure (Left e : acc)
                Left e@(CommandInvalidGasPurchaseFailure _) -> do
                    go (Left e : acc) rest
                Right a -> do
                    go (Right a : acc) rest

applyPactCmd
  :: (Logger logger)
  => TxIdxInBlock
  -> Miner
  -> Maybe Micros
  -> Pact4.Transaction
  -> StateT
      (T2 ModuleCache (Maybe Pact4.Gas))
      (PactBlockM logger tbl)
      (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson]))
applyPactCmd txIdxInBlock miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do
  dbEnv <- view psBlockDbEnv
  let pactDb = _cpPactDbEnv dbEnv
  prevBlockState <- liftIO $ fmap _benvBlockState $
    readMVar $ pdPactDbVar pactDb
  logger <- view (psServiceEnv . psLogger)
  gasLogger <- view (psServiceEnv . psGasLogger)
  txFailuresCounter <- view (psServiceEnv . psTxFailuresCounter)
  isGenesis <- view psIsGenesis
  v <- view chainwebVersion
  let
    -- for errors so fatal that the tx doesn't make it in the block
    onFatalError e
      | Just (Pact4BuyGasFailure f) <- fromException e = pure (Left (CommandInvalidGasPurchaseFailure f), T2 mcache maybeBlockGasRemaining)
      | Just t@(TxTimeout {}) <- fromException e = do
        -- timeouts can occur at any point during the transaction, even after
        -- gas has been bought (or even while gas is being redeemed, after the
        -- transaction proper is done). therefore we need to revert the block
        -- state ourselves if it happens.
        liftIO $ Pact4.modifyMVar'
          (pdPactDbVar pactDb)
          (benvBlockState .~ prevBlockState)
        pure (Left (CommandInvalidTxTimeout t), T2 mcache maybeBlockGasRemaining)
      | otherwise = throwM e
    requestedTxGasLimit = view Pact4.cmdGasLimit (Pact4.payloadObj <$> cmd)
    -- notice that we add 1 to the remaining block gas here, to distinguish the
    -- cases "tx used exactly as much gas remained in the block" (which is fine)
    -- and "tx attempted to use more gas than remains in the block" (which is
    -- illegal). for example: tx has a tx gas limit of 10000. the block has 5000
    -- remaining gas. therefore the tx is applied with a tx gas limit of 5001.
    -- if it uses 5001, that's illegal; if it uses 5000 or less, that's legal.
    newTxGasLimit = case maybeBlockGasRemaining of
      Nothing -> requestedTxGasLimit
      Just blockGasRemaining -> min (fromIntegral blockGasRemaining) requestedTxGasLimit
    gasLimitedCmd =
      set Pact4.cmdGasLimit newTxGasLimit (Pact4.payloadObj <$> cmd)
    initialGas = Pact4.initialGasOf (Pact4._cmdPayload cmd)
  let !hsh = Pact4._cmdHash cmd

  handle onFatalError $ do
    T2 result mcache' <- do
      txCtx <- getTxContext miner (Pact4.publicMetaOf gasLimitedCmd)
      let gasModel = getGasModel txCtx
      if isGenesis
      then liftIO $! Pact4.applyGenesisCmd logger pactDb Pact4.noSPVSupport txCtx gasLimitedCmd
      else do
        bhdb <- view (psServiceEnv . psBlockHeaderDb)
        parent <- view psParentHeader
        let spv = Pact4.pactSPV bhdb (_parentHeader parent)
        let
          !timeoutError = TxTimeout (pact4RequestKeyToTransactionHash $ Pact4.cmdToRequestKey cmd)
          txTimeout io = case txTimeLimit of
            Nothing -> do
              logFunctionText logger Debug $ "txTimeLimit was not set - defaulting to a function of the block gas limit"
              io
            Just limit -> do
              logFunctionText logger Debug $ "txTimeLimit was " <> sshow limit
              maybe (throwM timeoutError) return =<< newTimeout (fromIntegral limit) io
          txGas (T3 r _ _) = fromIntegral $ Pact4._crGas r
        T3 r c _warns <- do
          tracePactBlockM' "applyCmd" (\_ -> J.toJsonViaEncode hsh) txGas $ do
            liftIO $ txTimeout $
              Pact4.applyCmd v logger gasLogger txFailuresCounter pactDb miner gasModel txCtx txIdxInBlock spv gasLimitedCmd initialGas mcache ApplySend
        pure $ T2 r c

    if isGenesis
    then updateInitCacheM mcache'
    else liftPactServiceM $ debugResult "applyPactCmd" (Pact4.crLogs %~ fmap J.Array $ result)

    -- mark the tx as processed at the checkpointer.
    liftIO $ _cpRegisterProcessedTx dbEnv (coerce $ Pact4.toUntypedHash hsh)
    case maybeBlockGasRemaining of
      Just blockGasRemaining
        | Left _ <- Pact4._pactResult (Pact4._crResult result)
        , blockGasRemaining < fromIntegral requestedTxGasLimit
        -> throwM $ BlockGasLimitExceeded (fromIntegral requestedTxGasLimit - blockGasRemaining)
          -- ^ this tx attempted to consume more gas than remains in the
          -- block, so the block is invalid. we know this because failing
          -- transactions consume their entire gas limit.
      _ -> return ()
    let maybeBlockGasRemaining' = (\g -> g - Pact4._crGas result) <$> maybeBlockGasRemaining
    pure (Right result, T2 mcache' maybeBlockGasRemaining')

pact4TransactionsFromPayload
    :: Pact4.PactParserVersion
    -> PayloadData
    -> IO (Vector Pact4.Transaction)
pact4TransactionsFromPayload ppv plData = do
    vtrans <- fmap V.fromList $
              mapM toCWTransaction $
              toList (view 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 (Pact4.payloadCodec ppv) $
                                          _transactionBytes bs))

debugResult :: J.Encode a => Logger logger => Text -> a -> PactServiceM logger tbl ()
debugResult msg result =
  logDebugPact $ trunc $ msg <> " result: " <> J.encodeText result
  where
    trunc t | T.length t < limit = t
            | otherwise = T.take limit t <> " [truncated]"
    limit = 5000


-- | Calculate miner reward.
--
-- See: 'rewards/miner_rewards.csv'
--
minerReward
    :: ChainwebVersion
    -> BlockHeight
    -> Pact4.ParsedDecimal
minerReward v = Pact4.ParsedDecimal
    . _kda
    . minerRewardKda
    . blockMinerReward v
{-# INLINE minerReward #-}

data CRLogPair = CRLogPair Pact4.Hash [Pact4.TxLogJson]

instance J.Encode CRLogPair where
  build (CRLogPair h logs) = J.object
    [ "hash" J..= h
    , "rawLogs" J..= J.Array logs
    ]
  {-# INLINE build #-}

validateHashes
    :: BlockHeader
        -- ^ Current Header
    -> CheckablePayload
    -> Miner
    -> Transactions Pact4 (Pact4.CommandResult [Pact4.TxLogJson])
    -> Either PactException PayloadWithOutputs
validateHashes bHeader payload miner transactions =
    if newHash == prevHash
      then Right actualPwo
      else Left $ BlockValidationFailure $ BlockValidationFailureMsg $
              J.encodeText $ J.object
                [ "header" J..= J.encodeWithAeson (ObjectEncoded bHeader)
                , "actual" J..= J.encodeWithAeson actualPwo
                , "expected" J..?= case payload of
                    CheckablePayload _ -> Nothing
                    CheckablePayloadWithOutputs pwo -> Just $ J.encodeWithAeson pwo
                ]
  where

    actualPwo = toPayloadWithOutputs Pact4T miner transactions

    newHash = _payloadWithOutputsPayloadHash actualPwo
    prevHash = view blockPayloadHash bHeader

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 tbl (BlockInProgress Pact4)
continueBlock mpAccess blockInProgress = do
    v <- view chainwebVersion
    cid <- view chainId
    ParentHeader parent <- view psParentHeader
    let pHeight = view blockHeight parent
    let pHash = view blockHash parent
    liftIO $ do
          mpaProcessFork mpAccess parent
          mpaSetLastHeader mpAccess parent
    liftPactServiceM $
      logInfoPact $ "(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 .~ _blockHandlePending (_blockInProgressHandle blockInProgress)
          & benvBlockState . bsTxId .~ _blockHandleTxId (_blockInProgressHandle blockInProgress)

    blockGasLimit <- view (psServiceEnv . psBlockGasLimit)
    mTxTimeLimit <- view (psServiceEnv . psTxTimeLimit)

    let txTimeHeadroomFactor :: Double
        txTimeHeadroomFactor = 5
    let txTimeLimit :: Micros
        -- 2.5 microseconds per unit gas
        txTimeLimit = fromMaybe
          (round $ (2.5 * txTimeHeadroomFactor) * fromIntegral blockGasLimit)
          mTxTimeLimit

    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 $ pact4RequestKeyToTransactionHash . Pact4._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 $ logInfoPact $ "(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
            , _blockInProgressHandle = BlockHandle
              { _blockHandleTxId = _bsTxId finalBlockState
              , _blockHandlePending = _bsPendingBlock finalBlockState
              }
            , _blockInProgressParentHeader = newBlockParent
            , _blockInProgressRemainingGasLimit = finalGasLimit
            , _blockInProgressTransactions = Transactions
                { _transactionCoinbase = cb
                , _transactionPairs = txs
                }
            , _blockInProgressMiner = _blockInProgressMiner blockInProgress
            , _blockInProgressPactVersion = Pact4T
            , _blockInProgressChainwebVersion = v
            , _blockInProgressChainId = cid
            }
    return blockInProgress'
  where
    newBlockParent = _blockInProgressParentHeader blockInProgress


    getBlockTxs :: BlockFill -> PactBlockM logger tbl (Vector Pact4.Transaction)
    getBlockTxs bfState = do
      dbEnv <- view psBlockDbEnv
      psEnv <- ask
      let v = _chainwebVersion psEnv
          cid = _chainId psEnv
      logger <- view (psServiceEnv . psLogger)
      -- parent time needs to know if we're *actually* at genesis
      let parentTime =
            maybe
              (v ^?! versionGenesis . genesisTime . atChain cid)
              (view blockCreationTime . _parentHeader)
              newBlockParent
      ParentHeader parent <- view psParentHeader
      let pHeight = view blockHeight parent
      let pHash = view blockHash parent
      let validate bhi _bha txs = forM txs $ \tx -> runExceptT $ do
            validateRawChainwebTx logger v cid dbEnv (ParentCreationTime parentTime) bhi tx

      liftIO $!
        mpaGetBlock mpAccess bfState validate (pHeight + 1) pHash parentTime

    refill
      :: Word64
      -> Micros
      -> GrowableVec (Pact4.Transaction, Pact4.CommandResult [Pact4.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 $ logDebugPact $ "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
                logInfoPact $ "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' <- do
                      T2 txOuts mcOut <- applyPactCmds newTrans (_blockInProgressMiner blockInProgress) mc Nothing (Just txTimeLimit)
                      return $! T2 (V.force (V.zip newTrans txOuts)) mcOut

                    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, Pact4.CommandResult [Pact4.TxLogJson])
      -> GrowableVec TransactionHash -- ^ failed txs
      -> BlockFill
      -> [(Pact4.Transaction, Either CommandInvalidError (Pact4.CommandResult [Pact4.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 (pact4RequestKeyToTransactionHash $ Pact4._crReqKey cr)
              -- Decrement actual gas used from block limit
              let !g' = g - fromIntegral (Pact4._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 (CommandInvalidTxTimeout (TxTimeout h)) -> do
              liftIO $ Vec.push failures h
              liftPactServiceM $ logErrorPact $ "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

-- | This timeout variant returns Nothing if the timeout elapsed, regardless of whether or not it was actually able to interrupt its argument.
--   This is more robust in the face of scheduler behavior than the standard 'System.Timeout.timeout', with small timeouts.
newTimeout :: Int -> IO a -> IO (Maybe a)
newTimeout n f = do
  (timeSpan, a) <- Chronos.stopwatch (timeout n f)
  if Chronos.getTimespan timeSpan > fromIntegral (n * 1000)
  then return Nothing
  else return a