Skip to content

Commit

Permalink
Continue?
Browse files Browse the repository at this point in the history
  • Loading branch information
edmundnoble committed Jul 24, 2024
1 parent ef5f11b commit 5e2e92f
Show file tree
Hide file tree
Showing 41 changed files with 905 additions and 597 deletions.
2 changes: 1 addition & 1 deletion bench/Chainweb/Pact/Backend/Bench.hs
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,7 @@ cpRestoreAndSave
:: (Monoid q)
=> Checkpointer logger
-> Maybe BlockHeader
-> [(BlockHeader, ChainwebPactDbEnv logger -> IO q)]
-> [(BlockHeader, Pact4Db logger -> IO q)]
-> IO q
cpRestoreAndSave cp pc blks = snd <$> _cpRestoreAndSave cp (ParentHeader <$> pc)
(traverse Stream.yield [RunnableBlock $ \dbEnv _ -> (,bh) <$> fun (_cpPactDbEnv dbEnv) | (bh, fun) <- blks])
Expand Down
6 changes: 4 additions & 2 deletions chainweb.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -317,10 +317,10 @@ library
, Chainweb.Pact.Backend.Types
, Chainweb.Pact.Backend.Utils
, Chainweb.Pact.Conversion
, Chainweb.Pact.NoCoinbase
, Chainweb.Pact.PactService
, Chainweb.Pact.PactService.Checkpointer
, Chainweb.Pact.PactService.ExecBlock
, Chainweb.Pact.PactService.Pact4.ExecBlock
, Chainweb.Pact.PactService.Pact5.ExecBlock
, Chainweb.Pact.RestAPI
, Chainweb.Pact.RestAPI.Client
, Chainweb.Pact.RestAPI.EthSpv
Expand All @@ -331,9 +331,11 @@ library
, Chainweb.Pact.Service.PactInProcApi
, Chainweb.Pact.Service.PactQueue
, Chainweb.Pact.Service.Types
, Chainweb.Pact4.NoCoinbase
, Chainweb.Pact4.Templates
, Chainweb.Pact4.TransactionExec
, Chainweb.Pact4.Validations
, Chainweb.Pact5.NoCoinbase
, Chainweb.Pact5.Templates
, Chainweb.Pact5.TransactionExec
, Chainweb.Pact5.Types
Expand Down
6 changes: 6 additions & 0 deletions src/Chainweb/BlockHeader.hs
Original file line number Diff line number Diff line change
Expand Up @@ -98,6 +98,8 @@ module Chainweb.BlockHeader
, adjacentChainIds
, absBlockHeightDiff

, guardBlockHeader

-- * IsBlockHeader
, IsBlockHeader(..)

Expand Down Expand Up @@ -1188,3 +1190,7 @@ workSizeBytes
-> BlockHeight
-> Natural
workSizeBytes v h = headerSizeBytes v (unsafeChainId 0) h - 32

-- | TODO document
guardBlockHeader :: (ChainwebVersion -> ChainId -> BlockHeight -> a) -> BlockHeader -> a
guardBlockHeader k bh = k (_chainwebVersion bh) (_chainId bh) (_blockHeight bh)
19 changes: 4 additions & 15 deletions src/Chainweb/Chainweb/Configuration.hs
Original file line number Diff line number Diff line change
Expand Up @@ -613,25 +613,14 @@ parseVersion = constructVersion
constructVersion cliVersion fub bd disablePow' oldVersion = winningVersion
& versionBlockDelay .~ fromMaybe (_versionBlockDelay winningVersion) bd
& versionForks %~ HM.filterWithKey (\fork _ -> fork <= fromMaybe maxBound fub)
& versionPact4Upgrades .~
maybe (_versionPact4Upgrades winningVersion) (\fub' ->
& versionUpgrades .~
maybe (_versionUpgrades winningVersion) (\fub' ->
OnChains $ HM.mapWithKey
(\cid _ ->
case winningVersion ^?! versionForks . at fub' . _Just . onChain cid of
ForkNever -> error "Chainweb.Chainweb.Configuration.parseVersion: the fork upper bound never occurs in this version."
ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) (winningVersion ^?! versionPact4Upgrades . onChain cid)
ForkAtGenesis -> winningVersion ^?! versionPact4Upgrades . onChain cid
)
(HS.toMap (chainIds winningVersion))
) fub
& versionPact5Upgrades .~
maybe (_versionPact5Upgrades winningVersion) (\fub' ->
OnChains $ HM.mapWithKey
(\cid _ ->
case winningVersion ^?! versionForks . at fub' . _Just . onChain cid of
ForkNever -> error "Chainweb.Chainweb.Configuration.parseVersion: the fork upper bound never occurs in this version."
ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) (winningVersion ^?! versionPact5Upgrades . onChain cid)
ForkAtGenesis -> winningVersion ^?! versionPact5Upgrades . onChain cid
ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) (winningVersion ^?! versionUpgrades . onChain cid)
ForkAtGenesis -> winningVersion ^?! versionUpgrades . onChain cid
)
(HS.toMap (chainIds winningVersion))
) fub
Expand Down
9 changes: 7 additions & 2 deletions src/Chainweb/Chainweb/MinerResources.hs
Original file line number Diff line number Diff line change
Expand Up @@ -154,7 +154,9 @@ withMiningCoordination logger conf cdb inner
WorkStale -> return Nothing

forM_ mContinuableBlockInProgress $ \continuableBlockInProgress -> do
maybeNewBlock <- _pactContinueBlock pact cid continuableBlockInProgress
maybeNewBlock <- case continuableBlockInProgress of
ForPact4 block -> fmap ForPact4 <$> _pactContinueBlock pact cid block
ForPact5 block -> fmap ForPact5 <$> _pactContinueBlock pact cid block
-- if continuing returns NoHistory then the parent header
-- isn't available in the checkpointer right now.
-- in that case we just mark the payload as not stale.
Expand All @@ -164,7 +166,10 @@ withMiningCoordination logger conf cdb inner

logFunctionText (chainLogger cid logger) Debug
$ "refreshed block, old and new tx count: "
<> sshow (V.length $ _transactionPairs $ _blockInProgressTransactions continuableBlockInProgress, V.length $ _transactionPairs $ _blockInProgressTransactions newBlock)
<> sshow
( forAnyPactVersion (V.length . _transactionPairs . _blockInProgressTransactions) continuableBlockInProgress
, forAnyPactVersion (V.length . _transactionPairs . _blockInProgressTransactions) newBlock
)

atomically $ modifyTVar' tpw $
workForMiner ourMiner cid .~ WorkReady (NewBlockInProgress newBlock)
Expand Down
29 changes: 28 additions & 1 deletion src/Chainweb/Miner/RestAPI/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -206,7 +206,7 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d
(WorkStale, WorkStale) -> retry
(WorkAlreadyMined _, WorkAlreadyMined _) -> retry

(WorkReady (NewBlockInProgress lastBip), WorkReady (NewBlockInProgress currentBip))
(WorkReady (NewBlockInProgress (ForPact4 lastBip)), WorkReady (NewBlockInProgress (ForPact4 currentBip)))
| ParentHeader lastPh <- _blockInProgressParentHeader lastBip
, ParentHeader currentPh <- _blockInProgressParentHeader currentBip
, lastPh /= currentPh ->
Expand All @@ -230,6 +230,32 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d

-- no apparent change
| otherwise -> retry

(WorkReady (NewBlockInProgress (ForPact5 lastBip)), WorkReady (NewBlockInProgress (ForPact5 currentBip)))
| ParentHeader lastPh <- _blockInProgressParentHeader lastBip
, ParentHeader currentPh <- _blockInProgressParentHeader currentBip
, lastPh /= currentPh ->
-- we've got a new block on a new parent, we must've missed
-- the update where the old block became outdated.
-- miner should restart
return (WorkOutdated, currentBlockOnChain)

| lastTlen <- V.length (_transactionPairs $ _blockInProgressTransactions lastBip)
, currentTlen <- V.length (_transactionPairs $ _blockInProgressTransactions currentBip)
, lastTlen /= currentTlen ->
if currentTlen < lastTlen
then
-- our refreshed block somehow has less transactions,
-- but the same parent header, log this as a bizarre case
return (WorkRegressed, currentBlockOnChain)
else
-- we've got a block that's been extended with new transactions
-- miner should restart
return (WorkRefreshed, currentBlockOnChain)

-- no apparent change
| otherwise -> retry

(WorkReady (NewBlockPayload lastPh lastPwo), WorkReady (NewBlockPayload currentPh currentPwo))
| lastPh /= currentPh ->
-- we've got a new block on a new parent, we must've missed
Expand All @@ -245,6 +271,7 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d

-- no apparent change
| otherwise -> retry

(WorkReady _, WorkReady _) ->
error "awaitNewPrimedWork: impossible: NewBlockInProgress replaced by a NewBlockPayload"

Expand Down
4 changes: 2 additions & 2 deletions src/Chainweb/Pact/Backend/RelationalCheckpointer.hs
Original file line number Diff line number Diff line change
Expand Up @@ -151,7 +151,7 @@ doReadFrom
-> SQLiteEnv
-> MVar (DbCache PersistModuleData)
-> Maybe ParentHeader
-> (CurrentBlockDbEnv logger -> IO a)
-> (CurrentBlockDbEnv logger (DynamicPactDb logger) -> IO a)
-> IO (Historical a)
doReadFrom logger v cid sql moduleCacheVar maybeParent doRead = do
let currentHeight = case maybeParent of
Expand Down Expand Up @@ -209,7 +209,7 @@ doRestoreAndSave
-> IntraBlockPersistence
-> MVar (DbCache PersistModuleData)
-> Maybe ParentHeader
-> Stream (Of (RunnableBlock logger q)) IO r
-> Stream (Of (RunnableBlock logger (DynamicPactDb logger) q)) IO r
-> IO (r, q)
doRestoreAndSave logger v cid sql p moduleCacheVar rewindParent blocks = do
modifyMVar moduleCacheVar $ \moduleCache -> do
Expand Down
34 changes: 19 additions & 15 deletions src/Chainweb/Pact/Backend/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,9 @@ module Chainweb.Pact.Backend.Types
, _cpRewindTo
, ReadCheckpointer(..)
, CurrentBlockDbEnv(..)
, cpPactDbEnv
, cpRegisterProcessedTx
, cpLookupProcessedTx
, DynamicPactDb(..)
, makeDynamicPactDb
, assertDynamicPact4Db
Expand All @@ -48,8 +51,8 @@ module Chainweb.Pact.Backend.Types
, pdbcLogDir
, pdbcPersistDir
, pdbcPragmas
, ChainwebPactDbEnv
, CoreDb
, Pact4Db
, Pact5Db

, SQLiteRowDelta(..)
, SQLitePendingTableCreations
Expand Down Expand Up @@ -325,16 +328,16 @@ newtype BlockHandler logger a = BlockHandler
, MonadReader (BlockHandlerEnv logger)
)

type ChainwebPactDbEnv logger = PactDbEnv (BlockEnv logger)
type CoreDb = Pact5.PactDb Pact5.CoreBuiltin Pact5.Info
type Pact4Db logger = PactDbEnv (BlockEnv logger)
type Pact5Db = Pact5.PactDb Pact5.CoreBuiltin Pact5.Info

type ParentHash = BlockHash

-- | The parts of the checkpointer that do not mutate the database.
data ReadCheckpointer logger = ReadCheckpointer
{ _cpReadFrom ::
!(forall a. Maybe ParentHeader ->
(CurrentBlockDbEnv logger -> IO a) -> IO (Historical a))
(CurrentBlockDbEnv logger (DynamicPactDb logger) -> IO a) -> IO (Historical a))
-- ^ rewind to a particular block *in-memory*, producing a read-write snapshot
-- ^ of the database at that block to compute some value, after which the snapshot
-- is discarded and nothing is saved to the database.
Expand All @@ -361,8 +364,8 @@ data ReadCheckpointer logger = ReadCheckpointer
-- | A callback which writes a block's data to the input database snapshot,
-- and knows its parent header (Nothing if it's a genesis block).
-- Reports back its own header and some extra value.
newtype RunnableBlock logger a = RunnableBlock
{ runBlock :: CurrentBlockDbEnv logger -> Maybe ParentHeader -> IO (a, BlockHeader) }
newtype RunnableBlock db logger a = RunnableBlock
{ runBlock :: CurrentBlockDbEnv db logger -> Maybe ParentHeader -> IO (a, BlockHeader) }

-- | One makes requests to the checkpointer to query the pact state at the
-- current block or any earlier block, to extend the pact state with new blocks, and
Expand All @@ -372,7 +375,7 @@ data Checkpointer logger = Checkpointer
!(forall q r.
(HasCallStack, Monoid q) =>
Maybe ParentHeader ->
Stream (Of (RunnableBlock logger q)) IO r ->
Stream (Of (RunnableBlock logger (DynamicPactDb logger) q)) IO r ->
IO (r, q))
-- ^ rewind to a particular block, and play a stream of blocks afterward,
-- extending the chain and saving the result persistently. for example,
Expand Down Expand Up @@ -408,30 +411,30 @@ data Checkpointer logger = Checkpointer
_cpRewindTo :: Checkpointer logger -> Maybe ParentHeader -> IO ()
_cpRewindTo cp ancestor = void $ _cpRestoreAndSave cp
ancestor
(pure () :: Stream (Of (RunnableBlock logger ())) IO ())
(pure () :: Stream (Of (RunnableBlock logger (DynamicPactDb logger) ())) IO ())

data DynamicPactDb logger = Pact4Db (ChainwebPactDbEnv logger) | Pact5Db CoreDb
data DynamicPactDb logger = Pact4Db (Pact4Db logger) | Pact5Db Pact5Db

makeDynamicPactDb
:: ChainwebVersion -> ChainId -> BlockHeight
-> ChainwebPactDbEnv logger -> CoreDb
-> Pact4Db logger -> Pact5Db
-> DynamicPactDb logger
makeDynamicPactDb v cid bh pact4Db pact5Db
| pact5 v cid bh = Pact5Db pact5Db
| otherwise = Pact4Db pact4Db

-- TODO: make both of these errors InternalErrors, without incurring an import cycle
assertDynamicPact4Db :: HasCallStack => DynamicPactDb logger -> IO (ChainwebPactDbEnv logger)
assertDynamicPact4Db :: (MonadThrow m, HasCallStack) => DynamicPactDb logger -> m (Pact4Db logger)
assertDynamicPact4Db (Pact4Db pact4Db) = return pact4Db
assertDynamicPact4Db (Pact5Db _pact5Db) = error "expected Pact4 DB, got Pact5 DB"

assertDynamicPact5Db :: HasCallStack => DynamicPactDb logger -> IO CoreDb
assertDynamicPact5Db :: (MonadThrow m, HasCallStack) => DynamicPactDb logger -> m Pact5Db
assertDynamicPact5Db (Pact5Db pact5Db) = return pact5Db
assertDynamicPact5Db (Pact4Db _pact4Db) = error "expected Pact5 DB, got Pact4 DB"

-- this is effectively a read-write snapshot of the Pact state at a block.
data CurrentBlockDbEnv logger = CurrentBlockDbEnv
{ _cpPactDbEnv :: !(DynamicPactDb logger)
data CurrentBlockDbEnv logger db = CurrentBlockDbEnv
{ _cpPactDbEnv :: !db
, _cpRegisterProcessedTx :: !(P.PactHash -> IO ())
, _cpLookupProcessedTx ::
!(Vector P.PactHash -> IO (HashMap P.PactHash (T2 BlockHeight BlockHash)))
Expand Down Expand Up @@ -500,3 +503,4 @@ data Historical a
deriving anyclass NFData

makePrisms ''Historical
makeLenses ''CurrentBlockDbEnv
Loading

0 comments on commit 5e2e92f

Please sign in to comment.