diff --git a/chainweb.cabal b/chainweb.cabal index d49ee90e8a..0793b050e3 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -439,6 +439,7 @@ library , pem >=0.2 , primitive >= 0.7.1.0 , random >= 1.2 + , resource-pool >= 0.4 , rocksdb-haskell-kadena >= 1.1.0 , rosetta >= 1.0 , safe-exceptions >= 0.1 diff --git a/src/Chainweb/BlockHeader.hs b/src/Chainweb/BlockHeader.hs index 25a916de82..eae9bd0018 100644 --- a/src/Chainweb/BlockHeader.hs +++ b/src/Chainweb/BlockHeader.hs @@ -12,8 +12,10 @@ module Chainweb.BlockHeader ( -- * Newtype wrappers for function parameters I.ParentHeader(..) -, I.parentHeader +, I._ParentHeader +, I.HasParentHeader(..) , I.ParentCreationTime(..) +, I.UnminedPayload(..) -- * Block Payload Hash , I.BlockPayloadHash diff --git a/src/Chainweb/BlockHeader/Internal.hs b/src/Chainweb/BlockHeader/Internal.hs index 1643f2aa09..7e13278528 100644 --- a/src/Chainweb/BlockHeader/Internal.hs +++ b/src/Chainweb/BlockHeader/Internal.hs @@ -43,7 +43,8 @@ module Chainweb.BlockHeader.Internal ( -- * Newtype wrappers for function parameters ParentHeader(..) -, parentHeader +, _ParentHeader +, HasParentHeader(..) , ParentCreationTime(..) -- * Block Payload Hash @@ -129,6 +130,9 @@ module Chainweb.BlockHeader.Internal -- * CAS Constraint , BlockHeaderCas + +-- * As-yet unmined payloads +, UnminedPayload(..) ) where import Chainweb.BlockCreationTime @@ -614,8 +618,21 @@ newtype ParentHeader = ParentHeader deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) -parentHeader :: Lens' ParentHeader BlockHeader -parentHeader = lens _parentHeader $ \_ hdr -> ParentHeader hdr +_ParentHeader :: Iso' ParentHeader BlockHeader +_ParentHeader = iso _parentHeader ParentHeader + +class HasParentHeader c where + parentHeader :: Lens' c ParentHeader + +instance HasParentHeader ParentHeader where + parentHeader = id + +data UnminedPayload + = UnminedPayload + { unminedParent :: !(Maybe ParentHeader) + , unminedPayload :: !PayloadWithOutputs + } + deriving Show instance HasChainId ParentHeader where _chainId = _chainId . _parentHeader diff --git a/src/Chainweb/Chainweb/ChainResources.hs b/src/Chainweb/Chainweb/ChainResources.hs index 02573d1b1c..733965ed9d 100644 --- a/src/Chainweb/Chainweb/ChainResources.hs +++ b/src/Chainweb/Chainweb/ChainResources.hs @@ -25,6 +25,7 @@ module Chainweb.Chainweb.ChainResources , chainResMempool , chainResLogger , chainResPact +, chainResLatestNewBlockVar , withChainResources ) where @@ -55,6 +56,8 @@ import Chainweb.WebPactExecutionService import Chainweb.Storage.Table.RocksDB import Chainweb.Counter +import Control.Concurrent.STM +import Chainweb.BlockHeader -- -------------------------------------------------------------------------- -- -- Single Chain Resources @@ -64,6 +67,7 @@ data ChainResources logger = ChainResources , _chainResLogger :: !logger , _chainResMempool :: !(MempoolBackend Pact4.UnparsedTransaction) , _chainResPact :: PactExecutionService + , _chainResLatestNewBlockVar :: !(TMVar UnminedPayload) } makeLenses ''ChainResources @@ -100,8 +104,9 @@ withChainResources let mempoolCfg = mempoolCfg0 pexMv Mempool.withInMemoryMempool (setComponent "mempool" logger) mempoolCfg v $ \mempool -> do mpc <- MPCon.mkMempoolConsensus mempool cdb $ Just payloadDb + latestNewBlockVar <- newEmptyTMVarIO withPactService v cid logger (Just txFailuresCounter) mpc cdb - payloadDb pactDbDir pactConfig $ \requestQ -> do + payloadDb pactDbDir latestNewBlockVar pactConfig $ \requestQ -> do let pex = pes requestQ putMVar pexMv pex @@ -111,6 +116,7 @@ withChainResources , _chainResLogger = logger , _chainResMempool = mempool , _chainResPact = pex + , _chainResLatestNewBlockVar = latestNewBlockVar } where pes requestQ diff --git a/src/Chainweb/Miner/Coordinator.hs b/src/Chainweb/Miner/Coordinator.hs index d78dfd161f..1f17edaa86 100644 --- a/src/Chainweb/Miner/Coordinator.hs +++ b/src/Chainweb/Miner/Coordinator.hs @@ -48,7 +48,7 @@ module Chainweb.Miner.Coordinator import Control.Concurrent import Control.Concurrent.Async (withAsync) -import Control.Concurrent.STM (atomically, retry) +import Control.Concurrent.STM (atomically, retry, TMVar, tryTakeTMVar) import Control.Concurrent.STM.TVar import Control.DeepSeq (NFData) import Control.Lens @@ -129,41 +129,16 @@ data MiningCoordination logger tbl = MiningCoordination , _coord403s :: !(IORef Int) , _coordConf :: !CoordinationConfig , _coordUpdateStreamCount :: !(IORef Int) - , _coordPrimedWork :: !(TVar PrimedWork) + , _coordPrimedWork :: !(TMVar UnminedPayload) } --- | Precached payloads for Private Miners. This allows new work requests to be --- made as often as desired, without clogging the Pact queue. --- -newtype PrimedWork = - PrimedWork (HM.HashMap MinerId (HM.HashMap ChainId WorkState)) - deriving newtype (Semigroup, Monoid) - deriving stock Generic - deriving anyclass (Wrapped) - -data WorkState - = WorkReady NewBlock - -- ^ We have work ready for the miner - | WorkAlreadyMined BlockHash - -- ^ A block with this parent has already been mined and submitted to the - -- cut pipeline - we don't want to mine it again. - | WorkStale - -- ^ No work has been produced yet with the latest parent block on this - -- chain. - deriving stock (Show) - -isWorkReady :: WorkState -> Bool -isWorkReady = \case - WorkReady {} -> True - _ -> False - -- | Data shared between the mining threads represented by `newWork` and -- `publish`. -- --- The key is hash of the current block's payload. +-- The key is hash of the current block's payload and of the parent block. -- newtype MiningState = MiningState - { _miningState :: M.Map BlockPayloadHash (T3 Miner PayloadWithOutputs (Time Micros)) } + { _miningState :: M.Map (BlockPayloadHash, BlockHash) (T3 Miner PayloadWithOutputs (Time Micros)) } deriving stock (Generic) deriving newtype (Semigroup, Monoid) @@ -197,7 +172,7 @@ newWork -- ^ this is used to lookup parent headers that are not in the cut -- itself. -> PactExecutionService - -> TVar PrimedWork + -> HM.HashMap ChainId (TMVar UnminedPayload) -> Cut -> IO (Maybe (T2 WorkHeader PayloadWithOutputs)) newWork logFun choice eminer@(Miner mid _) hdb pact tpw c = do @@ -216,25 +191,21 @@ newWork logFun choice eminer@(Miner mid _) hdb pact tpw c = do -- to loop and select one of those chains. it is not a normal situation to -- have no chains with primed work if there are more than a couple chains. mpw <- atomically $ do - PrimedWork pw <- readTVar tpw mpw <- maybe retry return (HM.lookup mid pw) - guard (any isWorkReady mpw) - return mpw + unmined <- maybe retry return (HM.lookup cid mpw) + tryTakeTMVar (HM.lookup cid mpw) let mr = T2 - <$> HM.lookup cid mpw + <$> mpw <*> getCutExtension c cid case mr of - Just (T2 WorkStale _) -> do - logFun @T.Text Debug $ "newWork: chain " <> toText cid <> " has stale work" - newWork logFun Anything eminer hdb pact tpw c - Just (T2 (WorkAlreadyMined _) _) -> do + Just (T2 Nothing _) -> do logFun @T.Text Debug $ "newWork: chain " <> sshow cid <> " has a payload that was already mined" newWork logFun Anything eminer hdb pact tpw c Nothing -> do logFun @T.Text Debug $ "newWork: chain " <> toText cid <> " not mineable" newWork logFun Anything eminer hdb pact tpw c - Just (T2 (WorkReady newBlock) extension) -> do + Just (T2 newBlock extension) -> do let (primedParentHash, primedParentHeight, _) = newBlockParent newBlock if primedParentHash == view blockHash (_parentHeader (_cutExtensionParent extension)) then do diff --git a/src/Chainweb/Pact/Backend/Utils.hs b/src/Chainweb/Pact/Backend/Utils.hs index ffdafc4506..4d6b1eac42 100644 --- a/src/Chainweb/Pact/Backend/Utils.hs +++ b/src/Chainweb/Pact/Backend/Utils.hs @@ -23,8 +23,7 @@ module Chainweb.Pact.Backend.Utils ( -- * General utils - open2 - , chainDbFileName + chainDbFileName -- * Shared Pact database interactions , doLookupSuccessful , commitBlockStateToDatabase @@ -64,6 +63,7 @@ module Chainweb.Pact.Backend.Utils -- * SQLite runners , withSqliteDb , startSqliteDb + , startReadSqliteDb , stopSqliteDb , withSQLiteConnection , openSQLiteConnection @@ -116,7 +116,7 @@ import Chainweb.Version import Chainweb.Utils import Chainweb.BlockHash import Chainweb.BlockHeight -import Database.SQLite3.Direct hiding (open2) +import Database.SQLite3.Direct import GHC.Stack (HasCallStack) import qualified Data.ByteString.Short as SB import qualified Data.Vector as V @@ -127,6 +127,7 @@ import qualified Data.ByteString as BS import qualified Pact.Types.Persistence as Pact4 import Chainweb.Pact.Backend.Types import qualified Pact.Core.Persistence as Pact5 +import Network.Wai.Middleware.OpenApi (HasReadOnly(readOnly)) -- -------------------------------------------------------------------------- -- -- SQ3.Utf8 Encodings @@ -359,6 +360,18 @@ startSqliteDb cid logger dbDir doResetDb = do resetDb = removeDirectoryRecursive dbDir sqliteFile = dbDir chainDbFileName cid +startReadSqliteDb + :: Logger logger + => ChainId + -> logger + -> FilePath + -> IO SQLiteEnv +startReadSqliteDb cid logger dbDir = do + logFunctionText logger Debug $ "(read-only) opening sqlitedb named " <> T.pack sqliteFile + openSQLiteConnection sqliteFile chainwebPragmas + where + sqliteFile = dbDir chainDbFileName cid + chainDbFileName :: ChainId -> FilePath chainDbFileName cid = fold [ "pact-v1-chain-" @@ -374,7 +387,25 @@ withSQLiteConnection file ps = bracket (openSQLiteConnection file ps) closeSQLiteConnection openSQLiteConnection :: String -> [Pragma] -> IO SQLiteEnv -openSQLiteConnection file ps = open2 file >>= \case +openSQLiteConnection file ps = open_v2 + (fromString file) + (collapseFlags [sqlite_open_readwrite , sqlite_open_create , sqlite_open_nomutex]) + Nothing -- Nothing corresponds to the nullPtr + >>= \case + Left (err, msg) -> + internalError $ + "withSQLiteConnection: Can't open db with " + <> asString (show err) <> ": " <> asString (show msg) + Right r -> do + runPragmas r ps + return r + +openReadSQLiteConnection :: String -> [Pragma] -> IO SQLiteEnv +openReadSQLiteConnection file ps = open_v2 + (fromString file) + (collapseFlags [sqlite_open_readonly , sqlite_open_create , sqlite_open_nomutex]) + Nothing -- Nothing corresponds to the nullPtr + >>= \case Left (err, msg) -> internalError $ "withSQLiteConnection: Can't open db with " @@ -403,21 +434,16 @@ withTempSQLiteConnection = withSQLiteConnection "" withInMemSQLiteConnection :: [Pragma] -> (SQLiteEnv -> IO c) -> IO c withInMemSQLiteConnection = withSQLiteConnection ":memory:" -open2 :: String -> IO (Either (SQ3.Error, SQ3.Utf8) SQ3.Database) -open2 file = open_v2 - (fromString file) - (collapseFlags [sqlite_open_readwrite , sqlite_open_create , sqlite_open_fullmutex]) - Nothing -- Nothing corresponds to the nullPtr - collapseFlags :: [SQLiteFlag] -> SQLiteFlag collapseFlags xs = if Prelude.null xs then error "collapseFlags: You must pass a non-empty list" - else Prelude.foldr1 (.|.) xs + else Prelude.foldl1 (.|.) xs -sqlite_open_readwrite, sqlite_open_create, sqlite_open_fullmutex :: SQLiteFlag +sqlite_open_readwrite, sqlite_open_create, sqlite_open_nomutex :: SQLiteFlag sqlite_open_readwrite = 0x00000002 +sqlite_open_readonly = 0x00000001 sqlite_open_create = 0x00000004 -sqlite_open_fullmutex = 0x00010000 +sqlite_open_nomutex = 0x00008000 markTableMutation :: Utf8 -> BlockHeight -> Database -> IO () markTableMutation tablename blockheight db = do diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 09bed4c754..4ff6880021 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -14,6 +14,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} -- | -- Module: Chainweb.Pact.PactService @@ -109,7 +112,7 @@ import Chainweb.Payload import Chainweb.Payload.PayloadStore import Chainweb.Time import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.TreeDB +import qualified Chainweb.TreeDB as TreeDB import Chainweb.Utils hiding (check) import Chainweb.Version import Chainweb.Version.Guards @@ -143,7 +146,64 @@ 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 Data.Pool (Pool) +import qualified Data.Pool as Pool + +data ToRefreshBlock logger bip out = ToRefreshBlock + { logger :: logger + , continue :: bip -> IO (Historical bip) + , blockInProgressVar :: TMVar bip + , latestNewBlockVar :: TMVar out + , finalize :: bip -> out + , getParent :: bip -> Maybe ParentHeader + } + +refreshBlockStateMachine :: Logger logger => ToRefreshBlock logger bip out -> IO () +refreshBlockStateMachine res = do + -- note that if this is empty, we wait; taking from it is the way to make us stop + blockInProgress <- atomically $ readTMVar res.blockInProgressVar + let hasBlockChanged = do + blockInProgress' <- readTMVar res.blockInProgressVar + let newParentHeader = res.getParent blockInProgress' + let oldParentHeader = res.getParent blockInProgress + return (newParentHeader /= oldParentHeader) + maybeContinuedBlock <- race + (atomically (hasBlockChanged >>= guard)) + (res.continue blockInProgress) + case maybeContinuedBlock of + Left () -> logOutraced + Right NoHistory -> logOutraced + Right (Historical continuedBlock) -> do + changed <- atomically $ do + changed <- hasBlockChanged + when (not changed) $ do + writeTMVar res.blockInProgressVar continuedBlock + writeTMVar res.latestNewBlockVar (res.finalize continuedBlock) + return changed + when changed logOutraced + where + logOutraced = + logFunctionText res.logger Debug $ "Refresher outraced by new block" + +-- TODO: this doesn't work yet without a parallel SQL connection or something. +blockRefresher :: (CanReadablePayloadCas tbl, Logger logger) => MemPoolAccess -> Pool SQLiteEnv -> PactServiceEnv logger tbl -> PactServiceState -> ToRefreshBlock logger (ForSomePactVersion BlockInProgress) UnminedPayload +blockRefresher mempoolAccess readOnlySqlPool e s = ToRefreshBlock + { logger = e._psLogger + , continue = \blockInProgress -> do + Pool.withResource readOnlySqlPool $ \roSql -> do + -- TODO: no + let roEnv = e & psCheckpointer %~ \cp -> cp { cpSql = roSql } + evalPactServiceM s roEnv $ Checkpointer.readFrom (forAnyPactVersion _blockInProgressParentHeader blockInProgress) $ + case blockInProgress of + ForSomePactVersion Pact4T bip -> + SomeBlockM $ Pair (ForSomePactVersion Pact4T <$> Pact4.continueBlock mempoolAccess bip) (error "pact5") + ForSomePactVersion Pact5T bip -> + SomeBlockM $ Pair (error "pact4") (ForSomePactVersion Pact5T <$> Pact5.continueBlock mempoolAccess bip) + , blockInProgressVar = _psBlockInProgressVar e + , latestNewBlockVar = _psLatestNewBlockVar e + , finalize = UnminedPayload <$> forAnyPactVersion _blockInProgressParentHeader <*> forAnyPactVersion finalizeBlock + , getParent = forAnyPactVersion _blockInProgressParentHeader + } runPactService :: Logger logger @@ -157,12 +217,20 @@ runPactService -> BlockHeaderDb -> PayloadDb tbl -> SQLiteEnv + -> Pool SQLiteEnv + -> TMVar UnminedPayload -> PactServiceConfig -> IO () -runPactService ver cid chainwebLogger txFailuresCounter reqQ mempoolAccess bhDb pdb sqlenv config = - void $ withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config $ do +runPactService ver cid chainwebLogger txFailuresCounter reqQ mempoolAccess bhDb pdb sqlenv readOnlySqlPool newBlockVar config = + void $ withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv readOnlySqlPool newBlockVar config $ do initialPayloadState ver cid - serviceRequests mempoolAccess reqQ + e <- ask + s <- get + liftIO $ withAsync + (runForever (logFunction chainwebLogger) ("Refresh blocks " <> toText cid) $ + refreshBlockStateMachine (blockRefresher mempoolAccess readOnlySqlPool e s) + ) $ \_ -> + runPactServiceM s e $ serviceRequests mempoolAccess reqQ withPactService :: (Logger logger, CanReadablePayloadCas tbl) @@ -173,12 +241,15 @@ withPactService -> BlockHeaderDb -> PayloadDb tbl -> SQLiteEnv + -> Pool SQLiteEnv + -> TMVar UnminedPayload -> PactServiceConfig -> PactServiceM logger tbl a -> IO (T2 a PactServiceState) -withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config act = do +withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv readOnlySqlPool newBlockVar config act = do Checkpointer.withCheckpointerResources checkpointerLogger (_pactModuleCacheLimit config) sqlenv (_pactPersistIntraBlockWrites config) ver cid $ \checkpointer -> do let !rs = readRewards + blockInProgressVar <- newEmptyTMVarIO let !pse = PactServiceEnv { _psMempoolAccess = Nothing , _psCheckpointer = checkpointer @@ -196,6 +267,9 @@ withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config , _psEnableLocalTimeout = _pactEnableLocalTimeout config , _psTxFailuresCounter = txFailuresCounter , _psTxTimeLimit = _pactTxTimeLimit config + , _psMakeBlocks = _pactMakeBlocks config + , _psLatestNewBlockVar = newBlockVar + , _psBlockInProgressVar = blockInProgressVar } !pst = PactServiceState mempty @@ -306,7 +380,7 @@ initializeCoinContract v cid pwo = do lookupBlockHeader :: BlockHash -> Text -> PactServiceM logger tbl BlockHeader lookupBlockHeader bhash ctx = do bhdb <- view psBlockHeaderDb - liftIO $! lookupM bhdb bhash `catchAllSynchronous` \e -> + liftIO $! TreeDB.lookupM bhdb bhash `catchAllSynchronous` \e -> throwM $ BlockHeaderLookupFailure $ "failed lookup of parent header in " <> ctx <> ": " <> sshow e @@ -485,77 +559,89 @@ execNewBlock -> 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 + -> PactServiceM logger tbl () +execNewBlock mpAccess miner fill parent = pactLabel "execNewBlock" $ do + let pHeight = view blockHeight $ _parentHeader parent + let pHash = view blockHash $ _parentHeader parent logInfoPact $ "(parent height = " <> sshow pHeight <> ")" <> " (parent hash = " <> sshow pHash <> ")" blockGasLimit <- view psBlockGasLimit v <- view chainwebVersion cid <- view chainId - Checkpointer.readFrom (Just newBlockParent) $ - SomeBlockM $ Pair - (do - blockDbEnv <- view psBlockDbEnv - initCache <- initModuleCacheForBlock - coinbaseOutput <- runPact4Coinbase - 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) - ) + latestNewBlockVar <- view psLatestNewBlockVar + blockInProgressVar <- view psBlockInProgressVar + + Checkpointer.readFrom (Just parent) + (SomeBlockM $ Pair + (makeEmptyPact4Block v cid blockGasLimit) + (makeEmptyPact5Block v cid blockGasLimit)) >>= \case + NoHistory -> + logErrorPact + $ "Pact failed to find the parent header it was passed: " + <> blockHeaderShortDescription (_parentHeader parent) + Historical newEmptyBlockInProgress -> liftIO $ atomically $ do + latestNewBlock <- readTMVar latestNewBlockVar + let newParent = unminedParent latestNewBlock == Just parent + when newParent $ do + writeTMVar latestNewBlockVar UnminedPayload + { unminedParent = Just parent + , unminedPayload = forAnyPactVersion finalizeBlock newEmptyBlockInProgress + } + writeTMVar blockInProgressVar newEmptyBlockInProgress + where - (do - coinbaseOutput <- runPact5Coinbase 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) - ) + makeEmptyPact4Block v cid blockGasLimit = do + blockDbEnv <- view psBlockDbEnv + initCache <- initModuleCacheForBlock + coinbaseOutput <- runPact4Coinbase + miner + (Pact4.EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled True) + initCache + let pactDb = Pact4._cpPactDbEnv blockDbEnv + finalBlockState <- liftIO $ Pact4._benvBlockState + <$> readMVar (pdPactDbVar pactDb) + let hndl = BlockHandle (Pact4._bsTxId finalBlockState) (Pact4._bsPendingBlock finalBlockState) + let blockInProgress = BlockInProgress + { _blockInProgressModuleCache = Pact4ModuleCache initCache + -- ^ we do not use the module cache populated by coinbase in + -- subsequent transactions + , _blockInProgressHandle = hndl + , _blockInProgressParentHeader = Just parent + , _blockInProgressRemainingGasLimit = blockGasLimit + , _blockInProgressTransactions = Transactions + { _transactionCoinbase = coinbaseOutput + , _transactionPairs = mempty + } + , _blockInProgressMiner = miner + , _blockInProgressPactVersion = Pact4T + , _blockInProgressChainwebVersion = v + , _blockInProgressChainId = cid + } + return (ForPact4 blockInProgress) + + makeEmptyPact5Block v cid blockGasLimit = do + coinbaseOutput <- runPact5Coinbase 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 parent + , _blockInProgressRemainingGasLimit = blockGasLimit + , _blockInProgressTransactions = Transactions + { _transactionCoinbase = coinbaseOutput + , _transactionPairs = mempty + } + , _blockInProgressMiner = miner + , _blockInProgressPactVersion = Pact5T + , _blockInProgressChainwebVersion = v + , _blockInProgressChainId = cid + } + return (ForPact5 blockInProgress) execContinueBlock :: forall logger tbl pv. (Logger logger, CanReadablePayloadCas tbl) @@ -649,16 +735,16 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ -- lower bound must be an ancestor of upper. upperBound <- case maybeUpperBound of Just upperBound -> do - liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash upperBound)) >>= + liftIO (TreeDB.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)) >>= + liftIO (TreeDB.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)) >>= + liftIO (TreeDB.ancestorOf bhdb (view blockHash lowerBound) (view blockHash cur)) >>= flip unless (internalError "lower bound is not an ancestor of latest header") return cur @@ -670,7 +756,7 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ -- 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 + liftIO $ TreeDB.getBranchIncreasing bhdb upperBound (int lowerHeight) $ \blocks -> do heightRef <- newIORef lowerHeight withAsync (heightProgress lowerHeight (view blockHeight upperBound) heightRef (logInfo_ logger)) $ \_ -> do blocks @@ -690,7 +776,7 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ logger <- runPact $ view psLogger validationFailedRef <- newIORef False r <- blocks & Stream.mapM_ (\bh -> do - bhParent <- liftIO $ lookupParentM GenesisParentThrow bhdb bh + bhParent <- liftIO $ TreeDB.lookupParentM TreeDB.GenesisParentThrow bhdb bh let printValidationError (BlockValidationFailure (BlockValidationFailureMsg m)) = do writeIORef validationFailedRef True @@ -940,6 +1026,25 @@ execValidateBlock -> PactServiceM logger tbl (PayloadWithOutputs, Pact4.Gas) execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel "execValidateBlock" $ do bhdb <- view psBlockHeaderDb + -- tell the refresher loop to stop refreshing its block if it's not an ancestor of the block we're jumping to + do + blockInProgressVar <- view psBlockInProgressVar + latestNewBlockVar <- view psLatestNewBlockVar + blockInProgress <- liftIO $ atomically $ readTMVar blockInProgressVar + let maybeParentOfBlockInProgress = view (_ParentHeader . blockHash) <$> forAnyPactVersion _blockInProgressParentHeader blockInProgress + liftIO $ case maybeParentOfBlockInProgress of + -- the genesis block never goes out of style + Nothing -> return () + Just parentOfBlockInProgress + | parentOfBlockInProgress == view blockHash headerToValidate -> return () + | otherwise -> + TreeDB.ancestorOf bhdb parentOfBlockInProgress (view blockParent headerToValidate) >>= \case + True -> return () + False -> -- stop the block refresher loop, and don't mine + atomically $ do + void $ tryTakeTMVar blockInProgressVar + void $ tryTakeTMVar latestNewBlockVar + payloadDb <- view psPdb v <- view chainwebVersion cid <- view chainId @@ -957,7 +1062,7 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " -- 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) + Just <$> TreeDB.forkEntry bhdb currHeader' (_parentHeader ph) _ -> return Nothing -- check that we don't exceed the rewind limit. for the purpose @@ -979,7 +1084,7 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " kont (pure ()) Just (ParentHeader parentHeaderOfHeaderToValidate) -> let forkStartHeight = maybe (genesisHeight v cid) (succ . view blockHeight) commonAncestor - in getBranchIncreasing bhdb parentHeaderOfHeaderToValidate (fromIntegral forkStartHeight) kont + in TreeDB.getBranchIncreasing bhdb parentHeaderOfHeaderToValidate (fromIntegral forkStartHeight) kont ((), results) <- withPactState $ \runPact -> diff --git a/src/Chainweb/Pact/Service/BlockValidation.hs b/src/Chainweb/Pact/Service/BlockValidation.hs index 9137e762f1..4e0d72a4e4 100644 --- a/src/Chainweb/Pact/Service/BlockValidation.hs +++ b/src/Chainweb/Pact/Service/BlockValidation.hs @@ -52,7 +52,7 @@ import qualified Pact.Types.ChainMeta as Pact4 import Data.Text (Text) import qualified Pact.Types.Command as Pact4 -newBlock :: Miner -> NewBlockFill -> ParentHeader -> PactQueue -> IO (Historical (ForSomePactVersion BlockInProgress)) +newBlock :: Miner -> NewBlockFill -> ParentHeader -> PactQueue -> IO () newBlock mi fill parent reqQ = do let !msg = NewBlockMsg NewBlockReq diff --git a/src/Chainweb/Pact/Service/PactInProcApi.hs b/src/Chainweb/Pact/Service/PactInProcApi.hs index 490b3e5fa9..2ec4b22295 100644 --- a/src/Chainweb/Pact/Service/PactInProcApi.hs +++ b/src/Chainweb/Pact/Service/PactInProcApi.hs @@ -56,6 +56,10 @@ import GHC.Stack (HasCallStack) import Chainweb.Counter (Counter) import Chainweb.BlockCreationTime import Chainweb.Pact.Backend.Types +import Data.Pool (Pool) +import qualified Data.Pool as Pool +import Control.Concurrent.STM +import Chainweb.BlockHeader (UnminedPayload) -- | Initialization for Pact (in process) Api withPactService @@ -69,12 +73,19 @@ withPactService -> BlockHeaderDb -> PayloadDb tbl -> FilePath + -> TMVar UnminedPayload -> PactServiceConfig -> (PactQueue -> IO a) -> IO a -withPactService ver cid logger txFailuresCounter mpc bhdb pdb pactDbDir config action = - withSqliteDb cid logger pactDbDir (_pactResetDb config) $ \sqlenv -> - withPactService' ver cid logger txFailuresCounter mpa bhdb pdb sqlenv config action +withPactService ver cid logger txFailuresCounter mpc bhdb pdb pactDbDir latestNewBlockVar config action = + withSqliteDb cid logger pactDbDir (_pactResetDb config) $ \sqlenv -> do + readOnlySqlPool <- Pool.newPool $ Pool.defaultPoolConfig + (startReadSqliteDb cid logger pactDbDir) + stopSqliteDb + 10 -- seconds to keep them around unused + 2 -- connections at most + & Pool.setNumStripes (Just 2) -- two stripes, one connection per stripe + withPactService' ver cid logger txFailuresCounter mpa bhdb pdb sqlenv readOnlySqlPool latestNewBlockVar config action where mpa = pactMemPoolAccess mpc $ addLabel ("sub-component", "MempoolAccess") logger @@ -92,17 +103,19 @@ withPactService' -> BlockHeaderDb -> PayloadDb tbl -> SQLiteEnv + -> Pool SQLiteEnv + -> TMVar UnminedPayload -> PactServiceConfig -> (PactQueue -> IO a) -> IO a -withPactService' ver cid logger txFailuresCounter memPoolAccess bhDb pdb sqlenv config action = do +withPactService' ver cid logger txFailuresCounter memPoolAccess bhDb pdb sqlenv readOnlySqlPool latestNewBlockVar config action = do reqQ <- newPactQueue (_pactQueueSize config) race (concurrently_ (monitor reqQ) (server reqQ)) (action reqQ) >>= \case Left () -> error "Chainweb.Pact.Service.PactInProcApi: pact service terminated unexpectedly" Right a -> return a where server reqQ = runForever logg "pact-service" - $ PS.runPactService ver cid logger txFailuresCounter reqQ memPoolAccess bhDb pdb sqlenv config + $ PS.runPactService ver cid logger txFailuresCounter reqQ memPoolAccess bhDb pdb sqlenv readOnlySqlPool latestNewBlockVar config logg = logFunction logger monitor = runPactServiceQueueMonitor $ addLabel ("sub-component", "PactQueue") logger diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index 64ec19d8ce..9f18991ddc 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -53,6 +53,9 @@ module Chainweb.Pact.Types , psEnableLocalTimeout , psTxFailuresCounter , psTxTimeLimit + , psMakeBlocks + , psLatestNewBlockVar + , psBlockInProgressVar -- -- * Pact Service State , PactServiceState(..) @@ -251,6 +254,7 @@ import qualified Data.Vector as V import qualified Pact.Core.Hash as Pact5 import Data.Maybe import Chainweb.BlockCreationTime +import Control.Concurrent.Async -- | Gather tx logs for a block, along with last tx for each @@ -445,8 +449,10 @@ data PactServiceEnv logger tbl = PactServiceEnv , _psEnableLocalTimeout :: !Bool , _psTxFailuresCounter :: !(Maybe (Counter "txFailures")) , _psTxTimeLimit :: !(Maybe Micros) + , _psMakeBlocks :: !Bool + , _psLatestNewBlockVar :: !(TMVar UnminedPayload) + , _psBlockInProgressVar :: !(TMVar (ForSomePactVersion BlockInProgress)) } -makeLenses ''PactServiceEnv instance HasChainwebVersion (PactServiceEnv logger c) where _chainwebVersion = _chainwebVersion . _psBlockHeaderDb @@ -503,6 +509,7 @@ data PactServiceConfig = PactServiceConfig -- ^ *Only affects Pact5* -- Maximum allowed execution time for a single transaction. -- If 'Nothing', it's a function of the BlockGasLimit. + , _pactMakeBlocks :: !Bool } deriving (Eq,Show) @@ -522,6 +529,7 @@ testPactServiceConfig = PactServiceConfig , _pactEnableLocalTimeout = False , _pactPersistIntraBlockWrites = DoNotPersistIntraBlockWrites , _pactTxTimeLimit = Nothing + , _pactMakeBlocks = True } -- | This default value is only relevant for testing. In a chainweb-node the @GasLimit@ @@ -574,8 +582,6 @@ data PactServiceState = PactServiceState { _psInitCache :: !ModuleInitCache } -makeLenses ''PactServiceState - data PactBlockEnv logger pv tbl = PactBlockEnv { _psServiceEnv :: !(PactServiceEnv logger tbl) , _psParentHeader :: !ParentHeader @@ -583,12 +589,10 @@ data PactBlockEnv logger pv tbl = PactBlockEnv , _psBlockDbEnv :: !(PactDbFor logger pv) } -makeLenses ''PactBlockEnv - instance HasChainwebVersion (PactBlockEnv logger db tbl) where - chainwebVersion = psServiceEnv . chainwebVersion + _chainwebVersion = _chainwebVersion . _psServiceEnv instance HasChainId (PactBlockEnv logger db tbl) where - chainId = psServiceEnv . chainId + _chainId = _chainId . _psServiceEnv -- | The top level monad of PactService, notably allowing access to a -- checkpointer and module init cache and some configuration parameters. @@ -661,72 +665,6 @@ execPactServiceM execPactServiceM st env act = execStateT (runReaderT (_unPactServiceM act) env) st --- -------------------------------------------------------------------------- -- --- Pact Logger - -pactLogLevel :: String -> LogLevel -pactLogLevel "INFO" = Info -pactLogLevel "ERROR" = Error -pactLogLevel "DEBUG" = Debug -pactLogLevel "WARN" = Warn -pactLogLevel _ = Info - --- | Create Pact Loggers that use the the chainweb logging system as backend. --- -pactLoggers :: Logger logger => logger -> Pact4.Loggers -pactLoggers logger = Pact4.Loggers $ Pact4.mkLogger (error "ignored") fun (Pact4.LogRules mempty) - where - fun :: Pact4.LoggerLogFun - fun _ (Pact4.LogName n) cat msg = do - let namedLogger = addLabel ("logger", T.pack n) logger - logFunctionText namedLogger (pactLogLevel cat) $ T.pack msg - --- | Write log message --- -logg_ :: (MonadIO m, Logger logger) => logger -> LogLevel -> Text -> m () -logg_ logger level msg = liftIO $ logFunction logger level msg - --- | Write log message using the logger in Checkpointer environment - -logInfo_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logInfo_ l = logg_ l Info - -logWarn_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logWarn_ l = logg_ l Warn - -logError_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logError_ l = logg_ l Error - -logDebug_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logDebug_ l = logg_ l Debug - -logJsonTrace_ :: (MonadIO m, ToJSON a, Typeable a, NFData a, Logger logger) => logger -> LogLevel -> JsonLog a -> m () -logJsonTrace_ logger level msg = liftIO $ logFunction logger level msg - --- | Write log message using the logger in Checkpointer environment --- -logPact :: (Logger logger) => LogLevel -> Text -> PactServiceM logger tbl () -logPact level msg = view psLogger >>= \l -> logg_ l level msg - -logInfoPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logInfoPact msg = view psLogger >>= \l -> logInfo_ l msg - -logWarnPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logWarnPact msg = view psLogger >>= \l -> logWarn_ l msg - -logErrorPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logErrorPact msg = view psLogger >>= \l -> logError_ l msg - -logDebugPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logDebugPact msg = view psLogger >>= \l -> logDebug_ l msg - -logJsonTracePact :: (ToJSON a, Typeable a, NFData a, Logger logger) => LogLevel -> JsonLog a -> PactServiceM logger tbl () -logJsonTracePact level msg = view psLogger >>= \l -> logJsonTrace_ l level msg - -localLabelPact :: (Logger logger) => (Text, Text) -> PactServiceM logger tbl x -> PactServiceM logger tbl x -localLabelPact lbl x = do - locally psLogger (addLabel lbl) x - data PactServiceException = PactServiceIllegalRewind { _attemptedRewindTo :: !(Maybe (BlockHeight, BlockHash)) @@ -744,8 +682,6 @@ instance Show PactServiceException where instance Exception PactServiceException -makePrisms ''Historical - -- | Value that represents how far to go backwards while rewinding. newtype RewindDepth = RewindDepth { _rewindDepth :: Word64 } deriving (Eq, Ord) @@ -780,8 +716,6 @@ data LocalResult | LocalTimeout deriving stock (Show, Generic) -makePrisms ''LocalResult - instance J.Encode LocalResult where build (MetadataValidationFailure e) = J.object [ "preflightValidationFailures" J..= J.Array (J.text <$> e) @@ -895,7 +829,7 @@ instance Show SubmittedRequestMsg where data RequestMsg r where ContinueBlockMsg :: !(ContinueBlockReq pv) -> RequestMsg (Historical (BlockInProgress pv)) - NewBlockMsg :: !NewBlockReq -> RequestMsg (Historical (ForSomePactVersion BlockInProgress)) + NewBlockMsg :: !NewBlockReq -> RequestMsg () ValidateBlockMsg :: !ValidateBlockReq -> RequestMsg PayloadWithOutputs LocalMsg :: !LocalReq -> RequestMsg LocalResult LookupPactTxsMsg :: !LookupPactTxsReq -> RequestMsg (HashMap ShortByteString (T2 BlockHeight BlockHash)) @@ -1051,6 +985,7 @@ data BlockInProgress pv = BlockInProgress , _blockInProgressTransactions :: !(Transactions pv (CommandResultFor pv)) , _blockInProgressPactVersion :: !(PactVersionT pv) } + instance Eq (BlockInProgress pv) where bip == bip' = case (_blockInProgressPactVersion bip, _blockInProgressPactVersion bip') of @@ -1199,5 +1134,76 @@ instance NFData r => NFData (Transactions Pact5 r) where rnf (_transactionPairs txs) `seq` rnf (_transactionCoinbase) +makePrisms ''LocalResult +makePrisms ''Historical +makeLenses ''PactServiceState +makeLenses ''PactBlockEnv makeLenses 'Transactions makeLenses 'BlockInProgress +makeLenses ''PactServiceEnv + +-- -------------------------------------------------------------------------- -- +-- Pact Logger + +pactLogLevel :: String -> LogLevel +pactLogLevel "INFO" = Info +pactLogLevel "ERROR" = Error +pactLogLevel "DEBUG" = Debug +pactLogLevel "WARN" = Warn +pactLogLevel _ = Info + +-- | Create Pact Loggers that use the the chainweb logging system as backend. +-- +pactLoggers :: Logger logger => logger -> Pact4.Loggers +pactLoggers logger = Pact4.Loggers $ Pact4.mkLogger (error "ignored") fun (Pact4.LogRules mempty) + where + fun :: Pact4.LoggerLogFun + fun _ (Pact4.LogName n) cat msg = do + let namedLogger = addLabel ("logger", T.pack n) logger + logFunctionText namedLogger (pactLogLevel cat) $ T.pack msg + +-- | Write log message +-- +logg_ :: (MonadIO m, Logger logger) => logger -> LogLevel -> Text -> m () +logg_ logger level msg = liftIO $ logFunction logger level msg + +-- | Write log message using the logger in Checkpointer environment + +logInfo_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logInfo_ l = logg_ l Info + +logWarn_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logWarn_ l = logg_ l Warn + +logError_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logError_ l = logg_ l Error + +logDebug_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logDebug_ l = logg_ l Debug + +logJsonTrace_ :: (MonadIO m, ToJSON a, Typeable a, NFData a, Logger logger) => logger -> LogLevel -> JsonLog a -> m () +logJsonTrace_ logger level msg = liftIO $ logFunction logger level msg + +-- | Write log message using the logger in Checkpointer environment +-- +logPact :: (Logger logger) => LogLevel -> Text -> PactServiceM logger tbl () +logPact level msg = view psLogger >>= \l -> logg_ l level msg + +logInfoPact :: (Logger logger) => Text -> PactServiceM logger tbl () +logInfoPact msg = view psLogger >>= \l -> logInfo_ l msg + +logWarnPact :: (Logger logger) => Text -> PactServiceM logger tbl () +logWarnPact msg = view psLogger >>= \l -> logWarn_ l msg + +logErrorPact :: (Logger logger) => Text -> PactServiceM logger tbl () +logErrorPact msg = view psLogger >>= \l -> logError_ l msg + +logDebugPact :: (Logger logger) => Text -> PactServiceM logger tbl () +logDebugPact msg = view psLogger >>= \l -> logDebug_ l msg + +logJsonTracePact :: (ToJSON a, Typeable a, NFData a, Logger logger) => LogLevel -> JsonLog a -> PactServiceM logger tbl () +logJsonTracePact level msg = view psLogger >>= \l -> logJsonTrace_ l level msg + +localLabelPact :: (Logger logger) => (Text, Text) -> PactServiceM logger tbl x -> PactServiceM logger tbl x +localLabelPact lbl x = do + locally psLogger (addLabel lbl) x diff --git a/src/Chainweb/Version.hs b/src/Chainweb/Version.hs index a4d4a6d292..6db049855b 100644 --- a/src/Chainweb/Version.hs +++ b/src/Chainweb/Version.hs @@ -354,6 +354,7 @@ instance NFData (PactVersionT v) where data ForSomePactVersion f = forall pv. ForSomePactVersion (PactVersionT pv) (f pv) forAnyPactVersion :: (forall pv. f pv -> a) -> ForSomePactVersion f -> a forAnyPactVersion k (ForSomePactVersion _ f) = k f + instance (forall pv. Eq (f pv)) => Eq (ForSomePactVersion f) where ForSomePactVersion Pact4T f == ForSomePactVersion Pact4T f' = f == f' ForSomePactVersion Pact5T f == ForSomePactVersion Pact5T f' = f == f' @@ -746,4 +747,3 @@ onAllChains v f = OnChains <$> HM.traverseWithKey (\cid () -> f cid) (HS.toMap (chainIds v)) - diff --git a/src/Chainweb/WebPactExecutionService.hs b/src/Chainweb/WebPactExecutionService.hs index 7fc3cc14f4..84eaf6f507 100644 --- a/src/Chainweb/WebPactExecutionService.hs +++ b/src/Chainweb/WebPactExecutionService.hs @@ -13,9 +13,9 @@ module Chainweb.WebPactExecutionService , mkWebPactExecutionService , mkPactExecutionService , emptyPactExecutionService - , NewBlock(..) - , newBlockToPayloadWithOutputs - , newBlockParent +-- , NewBlock(..) +-- , newBlockToPayloadWithOutputs +-- , newBlockParent ) where import Control.Lens @@ -56,21 +56,16 @@ import Chainweb.BlockCreationTime (BlockCreationTime) -- -------------------------------------------------------------------------- -- -- PactExecutionService -data NewBlock - = NewBlockInProgress !(ForSomePactVersion BlockInProgress) - | NewBlockPayload !ParentHeader !PayloadWithOutputs - deriving Show +-- newBlockToPayloadWithOutputs :: NewBlock -> PayloadWithOutputs +-- newBlockToPayloadWithOutputs (NewBlockInProgress bip) +-- = forAnyPactVersion finalizeBlock bip +-- newBlockToPayloadWithOutputs (NewBlockPayload _ pwo) +-- = pwo -newBlockToPayloadWithOutputs :: NewBlock -> PayloadWithOutputs -newBlockToPayloadWithOutputs (NewBlockInProgress bip) - = forAnyPactVersion finalizeBlock bip -newBlockToPayloadWithOutputs (NewBlockPayload _ pwo) - = pwo - -newBlockParent :: NewBlock -> (BlockHash, BlockHeight, BlockCreationTime) -newBlockParent (NewBlockInProgress (ForSomePactVersion _ bip)) = blockInProgressParent bip -newBlockParent (NewBlockPayload (ParentHeader ph) _) = - (view blockHash ph, view blockHeight ph, view blockCreationTime ph) +-- newBlockParent :: NewBlock -> (BlockHash, BlockHeight, BlockCreationTime) +-- newBlockParent (NewBlockInProgress (ForSomePactVersion _ bip)) = blockInProgressParent bip +-- newBlockParent (NewBlockPayload (ParentHeader ph) _) = +-- (view blockHash ph, view blockHeight ph, view blockCreationTime ph) -- | Service API for interacting with a single or multi-chain ("Web") pact service. -- Thread-safe to be called from multiple threads. Backend is queue-backed on a per-chain @@ -87,7 +82,7 @@ data PactExecutionService = PactExecutionService Miner -> NewBlockFill -> ParentHeader -> - IO (Historical NewBlock) + IO () ) , _pactContinueBlock :: !( forall pv. @@ -156,7 +151,7 @@ _webPactNewBlock -> Miner -> NewBlockFill -> ParentHeader - -> IO (Historical NewBlock) + -> IO () _webPactNewBlock = _pactNewBlock . _webPactExecutionService {-# INLINE _webPactNewBlock #-} @@ -212,7 +207,7 @@ mkPactExecutionService q = PactExecutionService { _pactValidateBlock = \h pd -> do validateBlock h pd q , _pactNewBlock = \_ m fill parent -> do - fmap NewBlockInProgress <$> newBlock m fill parent q + newBlock m fill parent q , _pactContinueBlock = \_ bip -> do continueBlock bip q , _pactLocal = \pf sv rd ct -> diff --git a/test/lib/Chainweb/Test/Pact4/Utils.hs b/test/lib/Chainweb/Test/Pact4/Utils.hs index 4ce86ef50b..9746107a3a 100644 --- a/test/lib/Chainweb/Test/Pact4/Utils.hs +++ b/test/lib/Chainweb/Test/Pact4/Utils.hs @@ -857,10 +857,7 @@ runCut v bdb pact genTime noncer miner = void $ _webPactValidateBlock pact h (CheckablePayloadWithOutputs pout) initializeSQLite :: IO SQLiteEnv -initializeSQLite = open2 file >>= \case - Left (_err, _msg) -> - internalError "initializeSQLite: A connection could not be opened." - Right r -> return r +initializeSQLite = openSQLiteConnection file where file = "" {- temporary sqlitedb -}