From 427a9994bb56f4f0770ad3058838d7e1caaf6820 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 11:31:23 -0500 Subject: [PATCH 01/16] Add libmpfr to readme I checked that libmpfr6 exists for both Jammy (Ubuntu 22) and Focal (Ubuntu 20) and libmpfr-dev is the version with headers. --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 0e36cab7d..7638493fb 100644 --- a/README.md +++ b/README.md @@ -85,12 +85,12 @@ The following packages must be installed on the host system: * ubuntu-20.04: ```bash - apt-get install ca-certificates libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd + apt-get install ca-certificates libmpfr6 libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd ``` * ubuntu-22.04: ```bash - apt-get install ca-certificates libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd + apt-get install ca-certificates libmpfr6 libgmp10 libssl1.1 libsnappy1v5 zlib1g liblz4-1 libbz2-1.0 libgflags2.2 zstd ``` Chainweb-node binaries for ubuntu-20.04 and ubuntu-22.04 can be found @@ -130,7 +130,7 @@ You need to install the development versions of the following libraries: On apt based distribution these can be installed as follows: ``` -apt-get install ca-certificates libssl-dev libgmp-dev libsnappy-dev zlib1g-dev liblz4-dev libbz2-dev libgflags-dev libzstd-dev +apt-get install ca-certificates libssl-dev libmpfr-dev libgmp-dev libsnappy-dev zlib1g-dev liblz4-dev libbz2-dev libgflags-dev libzstd-dev ``` To build a `chainweb-node` binary: From c445684fa2ab572dc0f94de9e9046a515d7ece51 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 11:53:07 -0500 Subject: [PATCH 02/16] Use pact 5 with data-default fix --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 94703e870..faae0139f 100644 --- a/cabal.project +++ b/cabal.project @@ -95,8 +95,8 @@ source-repository-package source-repository-package type: git location: https://github.com/kadena-io/pact-5.git - tag: c2f5fb7b19b2bc3e4153d1dd14711195c8fe774a - --sha256: 1nn719nsbwmry7fvyn4xv1zi2mm7a5q3s07whghw5gf17zqnjbda + tag: 4738d8e101069ee8add62a6fb7ada2f4079af89a + --sha256: 1sll6rb8w4i18gi0xzbk8c0yp26mv4knrq0cjl8rnn7c0dnmyf4l source-repository-package type: git From 0798ad22d2d3027e00874222afd0ebba11fed8f4 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 11:53:07 -0500 Subject: [PATCH 03/16] Emit Pact5TxFailureLogs --- src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs | 16 ++++++++++++++-- src/Chainweb/Pact/Types.hs | 6 +++--- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 670b2856b..5a1cb92d0 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -414,9 +414,10 @@ applyPactCmd env miner tx = StateT $ \(blockHandle, blockGasRemaining) -> do let spv = Pact5.pactSPV bhdb (_parentHeader parent) let txCtx = TxContext parent miner -- TODO: trace more info? + let rk = Pact5.RequestKey $ Pact5._cmdHash cmd (resultOrError, blockHandle') <- liftIO $ trace' (logFunction logger) "applyCmd" computeTrace (\_ -> 0) $ - doPact5DbTransaction dbEnv blockHandle (Just (Pact5.RequestKey $ Pact5._cmdHash cmd)) $ \pactDb -> + doPact5DbTransaction dbEnv blockHandle (Just rk) $ \pactDb -> if _psIsGenesis env then do logFunctionText logger Debug "running genesis command!" @@ -428,13 +429,24 @@ applyPactCmd env miner tx = StateT $ \(blockHandle, blockGasRemaining) -> do Right res -> return (Right (absurd <$> res)) else applyCmd logger gasLogger pactDb txCtx spv initialGas cmd liftIO $ case resultOrError of + -- unknown exceptions are logged specially, because they indicate bugs in Pact or chainweb Right Pact5.CommandResult { _crResult = Pact5.PactResultErr (Pact5.PEExecutionError (Pact5.UnknownException unknownExceptionMessage) _ _) } -> logFunctionText logger Error $ "Unknown exception encountered " <> unknownExceptionMessage - _ -> return () + Left gasBuyError -> + liftIO $ logFunction logger Debug + -- TODO: replace with better print function for gas buy errors + (Pact5TxFailureLog rk (sshow gasBuyError)) + Right Pact5.CommandResult + { _crResult = Pact5.PactResultErr err + } -> + liftIO $ logFunction logger Debug + (Pact5TxFailureLog rk (sshow err)) + _ -> + return () return $ (,blockHandle') <$> resultOrError where computeTrace (Left gasPurchaseFailure, _) = Aeson.object diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index 64ec19d8c..b3bacc507 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -552,12 +552,12 @@ instance LogMessage Pact4TxFailureLog where instance Show Pact4TxFailureLog where show m = T.unpack (logText m) -data Pact5TxFailureLog = Pact5TxFailureLog !Pact5.RequestKey !(Pact5.PactError Pact5.Info) !Text +data Pact5TxFailureLog = Pact5TxFailureLog !Pact5.RequestKey !Text deriving stock (Generic) deriving anyclass (NFData, Typeable) instance LogMessage Pact5TxFailureLog where - logText (Pact5TxFailureLog rk err msg) = - msg <> ": " <> sshow rk <> ": " <> sshow err + logText (Pact5TxFailureLog rk msg) = + "Failed tx " <> sshow rk <> ": " <> msg instance Show Pact5TxFailureLog where show m = T.unpack (logText m) From e2091dbc70b526e12bcbf71e4b5fee4e4ee5c8c4 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 13:58:13 -0500 Subject: [PATCH 04/16] Delete guardBlockHeader It was unused but is already a sort of flawed idea; usually the parent header is what should be guarded by. --- src/Chainweb/BlockHeader.hs | 2 -- src/Chainweb/BlockHeader/Internal.hs | 5 ----- 2 files changed, 7 deletions(-) diff --git a/src/Chainweb/BlockHeader.hs b/src/Chainweb/BlockHeader.hs index 25a916de8..c844e834f 100644 --- a/src/Chainweb/BlockHeader.hs +++ b/src/Chainweb/BlockHeader.hs @@ -78,8 +78,6 @@ module Chainweb.BlockHeader , I.adjacentChainIds , I.absBlockHeightDiff -, I.guardBlockHeader - -- * IsBlockHeader , I.IsBlockHeader(..) diff --git a/src/Chainweb/BlockHeader/Internal.hs b/src/Chainweb/BlockHeader/Internal.hs index 1643f2aa0..b3d75ca56 100644 --- a/src/Chainweb/BlockHeader/Internal.hs +++ b/src/Chainweb/BlockHeader/Internal.hs @@ -119,7 +119,6 @@ module Chainweb.BlockHeader.Internal , genesisBlockHeaders , genesisBlockHeadersAtHeight , genesisHeight -, guardBlockHeader , headerSizes , headerSizeBytes , workSizeBytes @@ -1161,7 +1160,3 @@ 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) From 1f45287d16bdea809229753cb646dbf944f8d939 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 13:59:21 -0500 Subject: [PATCH 05/16] Delete comment in mempool --- src/Chainweb/Mempool/InMem.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Chainweb/Mempool/InMem.hs b/src/Chainweb/Mempool/InMem.hs index 86308f0cc..9f2f7f62f 100644 --- a/src/Chainweb/Mempool/InMem.hs +++ b/src/Chainweb/Mempool/InMem.hs @@ -617,7 +617,6 @@ getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight p | ((txHash, (bytes, t)), r) <- V.toList (V.zip q oks) ] logFunctionText logg Debug $ "validateBatch badlisting: " <> sshow (map fst bad1) - -- V.partition snd $! V.zip q oks -- remove considered txs -- successful ones will be re-added at the end let !psq' = V.foldl' del psq0 q From 7f9911fd1fe57280a10e3281339f398142fed982 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 14:00:04 -0500 Subject: [PATCH 06/16] revert accidental capitalization of blockHeight in compaction --- src/Chainweb/Pact/Backend/Compaction.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Chainweb/Pact/Backend/Compaction.hs b/src/Chainweb/Pact/Backend/Compaction.hs index 02cf34fde..eae063fdb 100644 --- a/src/Chainweb/Pact/Backend/Compaction.hs +++ b/src/Chainweb/Pact/Backend/Compaction.hs @@ -540,7 +540,7 @@ createCheckpointerIndexes db logger = do log "Creating BlockHistory index" inTx db $ Pact.exec_ db - "CREATE UNIQUE INDEX IF NOT EXISTS BlockHistory_blockHeight_unique_ix ON BlockHistory (blockheight)" + "CREATE UNIQUE INDEX IF NOT EXISTS BlockHistory_blockheight_unique_ix ON BlockHistory (blockheight)" log "Creating VersionedTableCreation index" inTx db $ Pact.exec_ db @@ -548,13 +548,13 @@ createCheckpointerIndexes db logger = do log "Creating VersionedTableMutation index" inTx db $ Pact.exec_ db - "CREATE UNIQUE INDEX IF NOT EXISTS VersionedTableMutation_blockHeight_tablename_unique_ix ON VersionedTableMutation (blockheight, tablename)" + "CREATE UNIQUE INDEX IF NOT EXISTS VersionedTableMutation_blockheight_tablename_unique_ix ON VersionedTableMutation (blockheight, tablename)" log "Creating TransactionIndex indexes" inTx db $ Pact.exec_ db "CREATE UNIQUE INDEX IF NOT EXISTS TransactionIndex_txhash_unique_ix ON TransactionIndex (txhash)" inTx db $ Pact.exec_ db - "CREATE INDEX IF NOT EXISTS TransactionIndex_blockHeight_ix ON TransactionIndex (blockheight)" + "CREATE INDEX IF NOT EXISTS TransactionIndex_blockheight_ix ON TransactionIndex (blockheight)" -- | Create a single user table createUserTable :: Database -> Utf8 -> IO () From 0093b8133786b2eef68fc993da9b84d9d7251021 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 15:18:28 -0500 Subject: [PATCH 07/16] Reorganize the Pact database code This puts more Pact 4- and 5-specific code into their respective specific files, as well as moving some of the more general code to the more general file. Some more qualified imports are used as well to clear up any ambiguity and stop using version-specific code in version-non-specific codepaths. --- src/Chainweb/Pact/Backend/Utils.hs | 346 ++++++++++------- .../Pact/PactService/Checkpointer/Internal.hs | 86 ++--- src/Chainweb/Pact4/Backend/ChainwebPactDb.hs | 170 ++------- src/Chainweb/Pact5/Backend/ChainwebPactDb.hs | 357 +++++++++--------- 4 files changed, 463 insertions(+), 496 deletions(-) diff --git a/src/Chainweb/Pact/Backend/Utils.hs b/src/Chainweb/Pact/Backend/Utils.hs index ffdafc450..ccbdf7715 100644 --- a/src/Chainweb/Pact/Backend/Utils.hs +++ b/src/Chainweb/Pact/Backend/Utils.hs @@ -31,6 +31,11 @@ module Chainweb.Pact.Backend.Utils , createVersionedTable , tbl , initSchema + , rewindDbTo + , rewindDbToBlock + , rewindDbToGenesis + , getEndTxId + , getEndTxId' -- * Savepoints , withSavepoint , beginSavepoint @@ -43,20 +48,6 @@ module Chainweb.Pact.Backend.Utils , fromUtf8 , toTextUtf8 , asStringUtf8 - , domainTableName - , domainTableNameCore - , tableNameCore - , convKeySetName - , convKeySetNameCore - , convModuleName - , convModuleNameCore - , convNamespaceName - , convNamespaceNameCore - , convRowKey - , convRowKeyCore - , convPactId - , convPactIdCore - , convHashedModuleName , convSavepointName , expectSingleRowCol , expectSingle @@ -95,15 +86,11 @@ import System.LogLevel -- pact -import Pact.Types.Persistence -import Pact.Types.SQLite -import Pact.Types.Term - (KeySetName(..), ModuleName(..), NamespaceName(..), PactId(..)) +import qualified Pact.Types.Persistence as Pact4 +import qualified Pact.Types.SQLite as Pact4 import Pact.Types.Util (AsString(..)) -import qualified Pact.Core.Names as PCore -import qualified Pact.Core.Persistence as PCore -import qualified Pact.Core.Guards as PCore +import qualified Pact.Core.Persistence as Pact5 -- chainweb @@ -124,24 +111,20 @@ import qualified Data.HashMap.Strict as HashMap import Chainweb.Utils.Serialization import qualified Data.ByteString.Char8 as B8 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 Data.HashSet (HashSet) +import Chainweb.BlockHeader +import qualified Data.HashSet as HashSet +import Data.Text (Text) -- -------------------------------------------------------------------------- -- -- SQ3.Utf8 Encodings -instance AsString (PCore.Domain k v b i) where - asString = PCore.renderDomain - -instance AsString (PCore.TableName) where - asString = PCore.renderTableName - -toUtf8 :: T.Text -> SQ3.Utf8 +toUtf8 :: Text -> SQ3.Utf8 toUtf8 = SQ3.Utf8 . T.encodeUtf8 {-# INLINE toUtf8 #-} -fromUtf8 :: SQ3.Utf8 -> T.Text +fromUtf8 :: SQ3.Utf8 -> Text fromUtf8 (SQ3.Utf8 bytes) = T.decodeUtf8 bytes {-# INLINE fromUtf8 #-} @@ -153,62 +136,6 @@ asStringUtf8 :: AsString a => a -> SQ3.Utf8 asStringUtf8 = toUtf8 . asString {-# INLINE asStringUtf8 #-} -domainTableName :: Pact4.Domain k v -> SQ3.Utf8 -domainTableName = asStringUtf8 - -convKeySetName :: KeySetName -> SQ3.Utf8 -convKeySetName = toUtf8 . asString - -domainTableNameCore :: PCore.Domain k v b i -> SQ3.Utf8 -domainTableNameCore = asStringUtf8 - -tableNameCore :: PCore.TableName -> SQ3.Utf8 -tableNameCore = asStringUtf8 - -convKeySetNameCore :: PCore.KeySetName -> SQ3.Utf8 -convKeySetNameCore = toUtf8 . PCore.renderKeySetName - -convModuleName - :: Bool - -- ^ whether to apply module name fix - -> ModuleName - -> SQ3.Utf8 -convModuleName False (ModuleName name _) = toUtf8 name -convModuleName True mn = asStringUtf8 mn - -convModuleNameCore - :: Bool - -- ^ whether to apply module name fix - -> PCore.ModuleName - -> SQ3.Utf8 -convModuleNameCore False (PCore.ModuleName name _) = toUtf8 name -convModuleNameCore True mn = toUtf8 $ PCore.renderModuleName mn - - -convNamespaceName :: NamespaceName -> SQ3.Utf8 -convNamespaceName (NamespaceName name) = toUtf8 name - -convNamespaceNameCore :: PCore.NamespaceName -> SQ3.Utf8 -convNamespaceNameCore (PCore.NamespaceName name) = toUtf8 name - -convRowKey :: RowKey -> SQ3.Utf8 -convRowKey (RowKey name) = toUtf8 name - -convRowKeyCore :: PCore.RowKey -> SQ3.Utf8 -convRowKeyCore (PCore.RowKey name) = toUtf8 name - -convPactId :: PactId -> SQ3.Utf8 -convPactId = toUtf8 . sshow - --- to match legacy keys -convPactIdCore :: PCore.DefPactId -> SQ3.Utf8 -convPactIdCore pid = "PactId \"" <> toUtf8 (PCore.renderDefPactId pid) <> "\"" - -convSavepointName :: SavepointName -> SQ3.Utf8 -convSavepointName = toTextUtf8 - -convHashedModuleName :: PCore.HashedModuleName -> SQ3.Utf8 -convHashedModuleName = toUtf8 . PCore.renderHashedModuleName -- -------------------------------------------------------------------------- -- -- @@ -234,11 +161,14 @@ withSavepoint db name action = mask $ \resetMask -> do beginSavepoint :: SQLiteEnv -> SavepointName -> IO () beginSavepoint db name = - exec_ db $ "SAVEPOINT [" <> convSavepointName name <> "];" + Pact4.exec_ db $ "SAVEPOINT [" <> convSavepointName name <> "];" commitSavepoint :: SQLiteEnv -> SavepointName -> IO () commitSavepoint db name = - exec_ db $ "RELEASE SAVEPOINT [" <> convSavepointName name <> "];" + Pact4.exec_ db $ "RELEASE SAVEPOINT [" <> convSavepointName name <> "];" + +convSavepointName :: SavepointName -> SQ3.Utf8 +convSavepointName = toTextUtf8 -- | @rollbackSavepoint n@ rolls back all database updates since the most recent -- savepoint with the name @n@ and restarts the transaction. @@ -252,7 +182,7 @@ commitSavepoint db name = -- rollbackSavepoint :: SQLiteEnv -> SavepointName -> IO () rollbackSavepoint db name = - exec_ db $ "ROLLBACK TRANSACTION TO SAVEPOINT [" <> convSavepointName name <> "];" + Pact4.exec_ db $ "ROLLBACK TRANSACTION TO SAVEPOINT [" <> convSavepointName name <> "];" -- | @abortSavepoint n@ rolls back all database updates since the most recent -- savepoint with the name @n@ and removes it from the savepoint stack. @@ -281,9 +211,6 @@ instance HasTextRepresentation SavepointName where <> ". Valid names are " <> T.intercalate ", " (toText @SavepointName <$> [minBound .. maxBound]) {-# INLINE fromText #-} --- instance AsString SavepointName where --- asString = toText - expectSingleRowCol :: Show a => String -> [[a]] -> IO a expectSingleRowCol _ [[s]] = return s expectSingleRowCol s v = @@ -300,7 +227,7 @@ expectSingle desc v = "Expected single-" <> asString (show desc) <> " result, got: " <> asString (show v) -chainwebPragmas :: [Pragma] +chainwebPragmas :: [Pact4.Pragma] chainwebPragmas = [ "synchronous = NORMAL" , "journal_mode = WAL" @@ -318,12 +245,12 @@ chainwebPragmas = , "page_size = 1024" ] -execMulti :: Traversable t => SQ3.Database -> SQ3.Utf8 -> t [SType] -> IO () -execMulti db q rows = bracket (prepStmt db q) destroy $ \stmt -> do +execMulti :: Traversable t => SQ3.Database -> SQ3.Utf8 -> t [Pact4.SType] -> IO () +execMulti db q rows = bracket (Pact4.prepStmt db q) destroy $ \stmt -> do forM_ rows $ \row -> do SQ3.reset stmt >>= checkError SQ3.clearBindings stmt - bindParams stmt row + Pact4.bindParams stmt row SQ3.step stmt >>= checkError where checkError (Left e) = void $ fail $ "error during batch insert: " ++ show e @@ -369,18 +296,18 @@ chainDbFileName cid = fold stopSqliteDb :: SQLiteEnv -> IO () stopSqliteDb = closeSQLiteConnection -withSQLiteConnection :: String -> [Pragma] -> (SQLiteEnv -> IO c) -> IO c +withSQLiteConnection :: String -> [Pact4.Pragma] -> (SQLiteEnv -> IO c) -> IO c withSQLiteConnection file ps = bracket (openSQLiteConnection file ps) closeSQLiteConnection -openSQLiteConnection :: String -> [Pragma] -> IO SQLiteEnv +openSQLiteConnection :: String -> [Pact4.Pragma] -> IO SQLiteEnv openSQLiteConnection file ps = open2 file >>= \case Left (err, msg) -> internalError $ "withSQLiteConnection: Can't open db with " <> asString (show err) <> ": " <> asString (show msg) Right r -> do - runPragmas r ps + Pact4.runPragmas r ps return r closeSQLiteConnection :: SQLiteEnv -> IO () @@ -392,7 +319,7 @@ closeSQLiteConnection c = void $ close_v2 c -- -- Cf. https://www.sqlite.org/inmemorydb.html -- -withTempSQLiteConnection :: [Pragma] -> (SQLiteEnv -> IO c) -> IO c +withTempSQLiteConnection :: [Pact4.Pragma] -> (SQLiteEnv -> IO c) -> IO c withTempSQLiteConnection = withSQLiteConnection "" -- Using the special file name @:memory:@ causes sqlite to create a temporary in-memory @@ -400,7 +327,7 @@ withTempSQLiteConnection = withSQLiteConnection "" -- -- Cf. https://www.sqlite.org/inmemorydb.html -- -withInMemSQLiteConnection :: [Pragma] -> (SQLiteEnv -> IO c) -> IO c +withInMemSQLiteConnection :: [Pact4.Pragma] -> (SQLiteEnv -> IO c) -> IO c withInMemSQLiteConnection = withSQLiteConnection ":memory:" open2 :: String -> IO (Either (SQ3.Error, SQ3.Utf8) SQ3.Database) @@ -419,12 +346,6 @@ sqlite_open_readwrite = 0x00000002 sqlite_open_create = 0x00000004 sqlite_open_fullmutex = 0x00010000 -markTableMutation :: Utf8 -> BlockHeight -> Database -> IO () -markTableMutation tablename blockheight db = do - exec' db mutq [SText tablename, SInt (fromIntegral blockheight)] - where - mutq = "INSERT OR IGNORE INTO VersionedTableMutation VALUES (?,?);" - commitBlockStateToDatabase :: SQLiteEnv -> BlockHash -> BlockHeight -> BlockHandle -> IO () commitBlockStateToDatabase db hsh bh blockHandle = do let newTables = _pendingTableCreation $ _blockHandlePending blockHandle @@ -443,26 +364,33 @@ commitBlockStateToDatabase db hsh bh blockHandle = do :: [(Utf8, [SQLiteRowDelta])] -> IO () backendWriteUpdateBatch writesByTable = mapM_ writeTable writesByTable - where - prepRow (SQLiteRowDelta _ txid rowkey rowdata) = - [ SText (Utf8 rowkey) - , SInt (fromIntegral txid) - , SBlob rowdata + where + prepRow (SQLiteRowDelta _ txid rowkey rowdata) = + [ Pact4.SText (Utf8 rowkey) + , Pact4.SInt (fromIntegral txid) + , Pact4.SBlob rowdata ] - writeTable (tableName, writes) = do + writeTable (tableName, writes) = do execMulti db q (map prepRow writes) markTableMutation tableName bh db - where + where q = "INSERT OR REPLACE INTO " <> tbl tableName <> "(rowkey,txid,rowdata) VALUES(?,?,?)" - -- | Record a block as being in the history of the checkpointer - blockHistoryInsert :: TxId -> IO () + -- Mark the table as being mutated during this block, so that we know + -- to delete from it if we rewind past this block. + markTableMutation tablename blockheight db = do + Pact4.exec' db mutq [Pact4.SText tablename, Pact4.SInt (fromIntegral blockheight)] + where + mutq = "INSERT OR IGNORE INTO VersionedTableMutation VALUES (?,?);" + + -- | Record a block as being in the history of the checkpointer. + blockHistoryInsert :: Pact4.TxId -> IO () blockHistoryInsert t = - exec' db stmt - [ SInt (fromIntegral bh) - , SBlob (runPutS (encodeBlockHash hsh)) - , SInt (fromIntegral t) + Pact4.exec' db stmt + [ Pact4.SInt (fromIntegral bh) + , Pact4.SBlob (runPutS (encodeBlockHash hsh)) + , Pact4.SInt (fromIntegral t) ] where stmt = @@ -471,10 +399,15 @@ commitBlockStateToDatabase db hsh bh blockHandle = do createUserTable :: Utf8 -> IO () createUserTable tablename = do createVersionedTable tablename db - exec' db insertstmt insertargs + markTableCreation tablename + + -- Mark the table as being created during this block, so that we know + -- to drop it if we rewind past this block. + markTableCreation tablename = + Pact4.exec' db insertstmt insertargs where insertstmt = "INSERT OR IGNORE INTO VersionedTableCreation VALUES (?,?)" - insertargs = [SText tablename, SInt (fromIntegral bh)] + insertargs = [Pact4.SText tablename, Pact4.SInt (fromIntegral bh)] -- | Commit the index of pending successful transactions to the database indexPendingPactTransactions :: IO () @@ -483,7 +416,7 @@ commitBlockStateToDatabase db hsh bh blockHandle = do dbIndexTransactions txs where - toRow b = [SBlob b, SInt (fromIntegral bh)] + toRow b = [Pact4.SBlob b, Pact4.SInt (fromIntegral bh)] dbIndexTransactions txs = do let rows = map toRow $ toList txs execMulti db "INSERT INTO TransactionIndex (txhash, blockheight) \ @@ -496,8 +429,8 @@ tbl t@(Utf8 b) createVersionedTable :: Utf8 -> Database -> IO () createVersionedTable tablename db = do - exec_ db createtablestmt - exec_ db indexcreationstmt + Pact4.exec_ db createtablestmt + Pact4.exec_ db indexcreationstmt where ixName = tablename <> "_ix" createtablestmt = @@ -524,12 +457,12 @@ doLookupSuccessful db curHeight hashes = do ] qvals -- match query params above. first, hashes - = map (\h -> SBlob $ SB.fromShort h) hss + = map (\h -> Pact4.SBlob $ SB.fromShort h) hss -- then, the block height; we don't want to see txs from the -- current block in the db, because they'd show up in pending data - ++ [SInt $ fromIntegral (pred curHeight)] + ++ [Pact4.SInt $ fromIntegral (pred curHeight)] - qry db qtext qvals [RInt, RBlob, RBlob] >>= mapM go + Pact4.qry db qtext qvals [Pact4.RInt, Pact4.RBlob, Pact4.RBlob] >>= mapM go where -- NOTE: it's useful to keep the types of 'go' and 'buildResultMap' in sync -- for readability but also to ensure the compiler and reader infer the @@ -539,14 +472,15 @@ doLookupSuccessful db curHeight hashes = do buildResultMap xs = HashMap.fromList $ map (\(T3 txhash blockheight blockhash) -> (txhash, T2 blockheight blockhash)) xs - go :: [SType] -> IO (T3 SB.ShortByteString BlockHeight BlockHash) - go (SInt blockheight:SBlob blockhash:SBlob txhash:_) = do + go :: [Pact4.SType] -> IO (T3 SB.ShortByteString BlockHeight BlockHash) + go (Pact4.SInt blockheight:Pact4.SBlob blockhash:Pact4.SBlob txhash:_) = do !blockhash' <- either fail return $ runGetEitherS decodeBlockHash blockhash let !txhash' = SB.toShort txhash return $! T3 txhash' (fromIntegral blockheight) blockhash' go _ = fail "impossible" -- | Create all tables that exist pre-genesis +-- TODO: migrate this logic to the checkpointer itself? initSchema :: (Logger logger) => logger -> SQLiteEnv -> IO () initSchema logger sql = withSavepoint sql DbTransaction $ do @@ -554,11 +488,10 @@ initSchema logger sql = createTableCreationTable createTableMutationTable createTransactionIndexTable - create (domainTableName KeySets) - create (domainTableName Modules) - create (domainTableName Namespaces) - create (domainTableName Pacts) - -- TODO: migrate this logic to the checkpointer itself? + create (toUtf8 $ Pact5.renderDomain Pact5.DKeySets) + create (toUtf8 $ Pact5.renderDomain Pact5.DModules) + create (toUtf8 $ Pact5.renderDomain Pact5.DNamespaces) + create (toUtf8 $ Pact5.renderDomain Pact5.DDefPacts) create (toUtf8 $ Pact5.renderDomain Pact5.DModuleSource) where create tablename = do @@ -567,7 +500,7 @@ initSchema logger sql = createBlockHistoryTable :: IO () createBlockHistoryTable = - exec_ sql + Pact4.exec_ sql "CREATE TABLE IF NOT EXISTS BlockHistory \ \(blockheight UNSIGNED BIGINT NOT NULL,\ \ hash BLOB NOT NULL,\ @@ -576,7 +509,7 @@ initSchema logger sql = createTableCreationTable :: IO () createTableCreationTable = - exec_ sql + Pact4.exec_ sql "CREATE TABLE IF NOT EXISTS VersionedTableCreation\ \(tablename TEXT NOT NULL\ \, createBlockheight UNSIGNED BIGINT NOT NULL\ @@ -584,7 +517,7 @@ initSchema logger sql = createTableMutationTable :: IO () createTableMutationTable = - exec_ sql + Pact4.exec_ sql "CREATE TABLE IF NOT EXISTS VersionedTableMutation\ \(tablename TEXT NOT NULL\ \, blockheight UNSIGNED BIGINT NOT NULL\ @@ -592,11 +525,142 @@ initSchema logger sql = createTransactionIndexTable :: IO () createTransactionIndexTable = do - exec_ sql + Pact4.exec_ sql "CREATE TABLE IF NOT EXISTS TransactionIndex \ \ (txhash BLOB NOT NULL, \ \ blockheight UNSIGNED BIGINT NOT NULL, \ \ CONSTRAINT transactionIndexConstraint UNIQUE(txhash));" - exec_ sql + Pact4.exec_ sql "CREATE INDEX IF NOT EXISTS \ \ transactionIndexByBH ON TransactionIndex(blockheight)"; + +getEndTxId :: Text -> SQLiteEnv -> Maybe ParentHeader -> IO (Historical Pact4.TxId) +getEndTxId msg sql pc = case pc of + Nothing -> return (Historical 0) + Just (ParentHeader ph) -> getEndTxId' msg sql (view blockHeight ph) (view blockHash ph) + +getEndTxId' :: Text -> SQLiteEnv -> BlockHeight -> BlockHash -> IO (Historical Pact4.TxId) +getEndTxId' msg sql bh bhsh = do + r <- Pact4.qry sql + "SELECT endingtxid FROM BlockHistory WHERE blockheight = ? and hash = ?;" + [ Pact4.SInt $ fromIntegral bh + , Pact4.SBlob $ runPutS (encodeBlockHash bhsh) + ] + [Pact4.RInt] + case r of + [[Pact4.SInt tid]] -> return $ Historical (Pact4.TxId (fromIntegral tid)) + [] -> return NoHistory + _ -> internalError $ msg <> ".getEndTxId: expected single-row int result, got " <> sshow r + + +-- | Delete any state from the database newer than the input parent header. +-- Returns the ending txid of the input parent header. +rewindDbTo + :: SQLiteEnv + -> Maybe ParentHeader + -> IO Pact4.TxId +rewindDbTo db Nothing = do + rewindDbToGenesis db + return 0 +rewindDbTo db mh@(Just (ParentHeader ph)) = do + !historicalEndingTxId <- getEndTxId "rewindDbToBlock" db mh + endingTxId <- case historicalEndingTxId of + NoHistory -> + throwM + $ BlockHeaderLookupFailure + $ "rewindDbTo.getEndTxId: not in db: " + <> sshow ph + Historical endingTxId -> + return endingTxId + rewindDbToBlock db (view blockHeight ph) endingTxId + return endingTxId + +-- rewind before genesis, delete all user tables and all rows in all tables +rewindDbToGenesis + :: SQLiteEnv + -> IO () +rewindDbToGenesis db = do + Pact4.exec_ db "DELETE FROM BlockHistory;" + Pact4.exec_ db "DELETE FROM [SYS:KeySets];" + Pact4.exec_ db "DELETE FROM [SYS:Modules];" + Pact4.exec_ db "DELETE FROM [SYS:Namespaces];" + Pact4.exec_ db "DELETE FROM [SYS:Pacts];" + Pact4.exec_ db "DELETE FROM [SYS:ModuleSources];" + tblNames <- Pact4.qry_ db "SELECT tablename FROM VersionedTableCreation;" [Pact4.RText] + forM_ tblNames $ \t -> case t of + [Pact4.SText tn] -> Pact4.exec_ db ("DROP TABLE [" <> tn <> "];") + _ -> internalError "Something went wrong when resetting tables." + Pact4.exec_ db "DELETE FROM VersionedTableCreation;" + Pact4.exec_ db "DELETE FROM VersionedTableMutation;" + Pact4.exec_ db "DELETE FROM TransactionIndex;" + +-- | Rewind the database to a particular block, given the end tx id of that +-- block. +rewindDbToBlock + :: Database + -> BlockHeight + -> Pact4.TxId + -> IO () +rewindDbToBlock db bh endingTxId = do + tableMaintenanceRowsVersionedSystemTables + droppedtbls <- dropTablesAtRewind + vacuumTablesAtRewind droppedtbls + deleteHistory + clearTxIndex + where + dropTablesAtRewind :: IO (HashSet BS.ByteString) + dropTablesAtRewind = do + toDropTblNames <- Pact4.qry db findTablesToDropStmt + [Pact4.SInt (fromIntegral bh)] [Pact4.RText] + tbls <- fmap HashSet.fromList . forM toDropTblNames $ \case + [Pact4.SText tblname@(Utf8 tn)] -> do + Pact4.exec_ db $ "DROP TABLE IF EXISTS " <> tbl tblname + return tn + _ -> internalError rewindmsg + Pact4.exec' db + "DELETE FROM VersionedTableCreation WHERE createBlockheight > ?" + [Pact4.SInt (fromIntegral bh)] + return tbls + findTablesToDropStmt = + "SELECT tablename FROM VersionedTableCreation WHERE createBlockheight > ?;" + rewindmsg = + "rewindBlock: dropTablesAtRewind: Couldn't resolve the name of the table to drop." + + deleteHistory :: IO () + deleteHistory = + Pact4.exec' db "DELETE FROM BlockHistory WHERE blockheight > ?" + [Pact4.SInt (fromIntegral bh)] + + vacuumTablesAtRewind :: HashSet BS.ByteString -> IO () + vacuumTablesAtRewind droppedtbls = do + let processMutatedTables ms = fmap HashSet.fromList . forM ms $ \case + [Pact4.SText (Utf8 tn)] -> return tn + _ -> internalError "rewindBlock: vacuumTablesAtRewind: Couldn't resolve the name \ + \of the table to possibly vacuum." + mutatedTables <- Pact4.qry db + "SELECT DISTINCT tablename FROM VersionedTableMutation WHERE blockheight > ?;" + [Pact4.SInt (fromIntegral bh)] + [Pact4.RText] + >>= processMutatedTables + let toVacuumTblNames = HashSet.difference mutatedTables droppedtbls + forM_ toVacuumTblNames $ \tblname -> + Pact4.exec' db ("DELETE FROM " <> tbl (Utf8 tblname) <> " WHERE txid >= ?") + [Pact4.SInt $! fromIntegral endingTxId] + Pact4.exec' db "DELETE FROM VersionedTableMutation WHERE blockheight > ?;" + [Pact4.SInt (fromIntegral bh)] + + tableMaintenanceRowsVersionedSystemTables :: IO () + tableMaintenanceRowsVersionedSystemTables = do + Pact4.exec' db "DELETE FROM [SYS:KeySets] WHERE txid >= ?" tx + Pact4.exec' db "DELETE FROM [SYS:Modules] WHERE txid >= ?" tx + Pact4.exec' db "DELETE FROM [SYS:Namespaces] WHERE txid >= ?" tx + Pact4.exec' db "DELETE FROM [SYS:Pacts] WHERE txid >= ?" tx + Pact4.exec' db "DELETE FROM [SYS:ModuleSources] WHERE txid >= ?" tx + where + tx = [Pact4.SInt $! fromIntegral endingTxId] + + -- | Delete all future transactions from the index + clearTxIndex :: IO () + clearTxIndex = + Pact4.exec' db "DELETE FROM TransactionIndex WHERE blockheight > ?;" + [ Pact4.SInt (fromIntegral bh) ] diff --git a/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs b/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs index d043cef75..b9f1a14af 100644 --- a/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs +++ b/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs @@ -73,7 +73,6 @@ import Pact.Types.Command(RequestKey(..)) import Pact.Types.Hash (Hash(..)) import Pact.Types.Persistence import Pact.Types.SQLite -import Pact.Types.Util (AsString(..)) import qualified Pact.Core.Persistence as Pact5 @@ -82,7 +81,7 @@ import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.Logger -import qualified Chainweb.Pact4.Backend.ChainwebPactDb as PactDb +import qualified Chainweb.Pact4.Backend.ChainwebPactDb as Pact4 import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5 import Chainweb.Pact.Backend.DbCache @@ -97,6 +96,7 @@ import qualified Pact.Types.Persistence as Pact4 import qualified Pact.Core.Builtin as Pact5 import qualified Pact.Core.Evaluate as Pact5 import qualified Pact.Core.Names as Pact5 +import qualified Chainweb.Pact.Backend.Utils as PactDb withCheckpointerResources :: (Logger logger) @@ -172,10 +172,10 @@ readFrom res maybeParent pactVersion doRead = do | pact5 res.cpCwVersion res.cpChainId currentHeight -> internalError $ "Pact 4 readFrom executed on block height after Pact 5 fork, height: " <> sshow currentHeight | otherwise -> PactDb.getEndTxId "doReadFrom" res.cpSql maybeParent >>= traverse \startTxId -> do - newDbEnv <- newMVar $ PactDb.BlockEnv - (PactDb.mkBlockHandlerEnv res.cpCwVersion res.cpChainId currentHeight res.cpSql DoNotPersistIntraBlockWrites res.cpLogger) - (PactDb.initBlockState defaultModuleCacheLimit startTxId) - { PactDb._bsModuleCache = sharedModuleCache } + newDbEnv <- newMVar $ Pact4.BlockEnv + (Pact4.mkBlockHandlerEnv res.cpCwVersion res.cpChainId currentHeight res.cpSql DoNotPersistIntraBlockWrites res.cpLogger) + (Pact4.initBlockState defaultModuleCacheLimit startTxId) + { Pact4._bsModuleCache = sharedModuleCache } let -- is the parent the latest header, i.e., can we get away without rewinding? parentIsLatestHeader = case (latestHeader, maybeParent) of @@ -183,23 +183,23 @@ readFrom res maybeParent pactVersion doRead = do (Just (_, latestHash), Just (ParentHeader ph)) -> view blockHash ph == latestHash _ -> False - mkBlockDbEnv db = PactDb.CurrentBlockDbEnv - { PactDb._cpPactDbEnv = PactDbEnv db newDbEnv - , PactDb._cpRegisterProcessedTx = \hash -> - PactDb.runBlockEnv newDbEnv (PactDb.indexPactTransaction $ BS.fromShort $ coerce hash) - , PactDb._cpLookupProcessedTx = \hs -> + mkBlockDbEnv db = Pact4.CurrentBlockDbEnv + { Pact4._cpPactDbEnv = PactDbEnv db newDbEnv + , Pact4._cpRegisterProcessedTx = \hash -> + Pact4.runBlockEnv newDbEnv (Pact4.indexPactTransaction $ BS.fromShort $ coerce hash) + , Pact4._cpLookupProcessedTx = \hs -> HashMap.mapKeys coerce <$> doLookupSuccessful res.cpSql currentHeight (coerce hs) } pactDb - | parentIsLatestHeader = PactDb.chainwebPactDb - | otherwise = PactDb.rewoundPactDb currentHeight startTxId + | parentIsLatestHeader = Pact4.chainwebPactDb + | otherwise = Pact4.rewoundPactDb currentHeight startTxId r <- doRead (mkBlockDbEnv pactDb) (emptyBlockHandle startTxId) - finalCache <- PactDb._bsModuleCache . PactDb._benvBlockState <$> readMVar newDbEnv + finalCache <- Pact4._bsModuleCache . Pact4._benvBlockState <$> readMVar newDbEnv return (r, finalCache) Pact5T | pact5 res.cpCwVersion res.cpChainId currentHeight -> - Pact5.getEndTxId "doReadFrom" res.cpSql maybeParent >>= traverse \startTxId -> do + PactDb.getEndTxId "doReadFrom" res.cpSql maybeParent >>= traverse \startTxId -> do let -- is the parent the latest header, i.e., can we get away without rewinding? -- TODO: just do this inside of the chainwebPactCoreBlockDb function? @@ -219,10 +219,10 @@ readFrom res maybeParent pactVersion doRead = do } let upperBound | parentIsLatestHeader = Nothing - | otherwise = Just (currentHeight, startTxId) + | otherwise = Just (currentHeight, coerce @Pact4.TxId @Pact5.TxId startTxId) let pactDb - = Pact5.chainwebPactCoreBlockDb upperBound blockHandlerEnv - r <- doRead pactDb (emptyBlockHandle (coerce @Pact5.TxId @Pact4.TxId startTxId)) + = Pact5.chainwebPactBlockDb upperBound blockHandlerEnv + r <- doRead pactDb (emptyBlockHandle startTxId) return (r, sharedModuleCache) | otherwise -> internalError $ @@ -302,34 +302,34 @@ restoreAndSave res rewindParent blocks = do "Pact 4 block executed on block height after Pact 5 fork, height: " <> sshow bh | otherwise -> do -- prepare a fresh block state - let handlerEnv = PactDb.mkBlockHandlerEnv res.cpCwVersion res.cpChainId bh res.cpSql res.cpIntraBlockPersistence res.cpLogger - let state = (PactDb.initBlockState defaultModuleCacheLimit txid) - { PactDb._bsModuleCache = moduleCache } - dbMVar <- newMVar PactDb.BlockEnv - { PactDb._blockHandlerEnv = handlerEnv - , PactDb._benvBlockState = state + let handlerEnv = Pact4.mkBlockHandlerEnv res.cpCwVersion res.cpChainId bh res.cpSql res.cpIntraBlockPersistence res.cpLogger + let state = (Pact4.initBlockState defaultModuleCacheLimit txid) + { Pact4._bsModuleCache = moduleCache } + dbMVar <- newMVar Pact4.BlockEnv + { Pact4._blockHandlerEnv = handlerEnv + , Pact4._benvBlockState = state } let - mkBlockDbEnv db = PactDb.CurrentBlockDbEnv - { PactDb._cpPactDbEnv = db - , PactDb._cpRegisterProcessedTx = \hash -> - PactDb.runBlockEnv dbMVar (PactDb.indexPactTransaction $ BS.fromShort $ coerce hash) - , PactDb._cpLookupProcessedTx = \hs -> + mkBlockDbEnv db = Pact4.CurrentBlockDbEnv + { Pact4._cpPactDbEnv = db + , Pact4._cpRegisterProcessedTx = \hash -> + Pact4.runBlockEnv dbMVar (Pact4.indexPactTransaction $ BS.fromShort $ coerce hash) + , Pact4._cpLookupProcessedTx = \hs -> fmap (HashMap.mapKeys coerce) $ doLookupSuccessful res.cpSql bh $ coerce hs } -- execute the block - let pact4Db = PactDbEnv PactDb.chainwebPactDb dbMVar + let pact4Db = PactDbEnv Pact4.chainwebPactDb dbMVar (m', newBh) <- runBlock (mkBlockDbEnv pact4Db) maybeParent -- grab any resulting state that we're interested in keeping - nextState <- PactDb._benvBlockState <$> takeMVar dbMVar - let !nextTxId = PactDb._bsTxId nextState - let !nextModuleCache = PactDb._bsModuleCache nextState - when (isJust (PactDb._bsPendingTx nextState)) $ + nextState <- Pact4._benvBlockState <$> takeMVar dbMVar + let !nextTxId = Pact4._bsTxId nextState + let !nextModuleCache = Pact4._bsModuleCache nextState + when (isJust (Pact4._bsPendingTx nextState)) $ internalError "tx still in progress at the end of block" -- compute the accumulator early let !m'' = m <> m' @@ -347,7 +347,7 @@ restoreAndSave res rewindParent blocks = do -- persist any changes to the database PactDb.commitBlockStateToDatabase res.cpSql (view blockHash newBh) (view blockHeight newBh) - (BlockHandle (PactDb._bsTxId nextState) (PactDb._bsPendingBlock nextState)) + (BlockHandle (Pact4._bsTxId nextState) (Pact4._bsPendingBlock nextState)) return (m'', Just (ParentHeader newBh), nextTxId, nextModuleCache) Pact5RunnableBlock runBlock | pact5 res.cpCwVersion res.cpChainId bh -> do @@ -361,7 +361,7 @@ restoreAndSave res rewindParent blocks = do , Pact5._blockHandlerMode = Pact5.Transactional , Pact5._blockHandlerPersistIntraBlockWrites = res.cpIntraBlockPersistence } - pactDb = Pact5.chainwebPactCoreBlockDb Nothing blockEnv + pactDb = Pact5.chainwebPactBlockDb Nothing blockEnv -- run the block ((m', nextBlockHeader), blockHandle) <- runBlock pactDb maybeParent (emptyBlockHandle txid) -- compute the accumulator early @@ -451,6 +451,7 @@ getBlockParent v cid db (bh, hash) qtext = "SELECT hash FROM BlockHistory WHERE blockheight = ?" +-- TODO: do this in ChainwebPactDb instead? getBlockHistory :: SQLiteEnv -> BlockHeader @@ -470,7 +471,7 @@ getBlockHistory db blockHeader d = do Historical startTxId -> return $ fromIntegral startTxId - let tname = domainTableNameCore d + let tname = Pact5.domainTableName d history <- queryHistory tname startTxId endTxId let (!hkeys,tmap) = foldl' procTxHist (S.empty,mempty) history !prev <- M.fromList . catMaybes <$> mapM (queryPrev tname startTxId) (S.toList hkeys) @@ -496,7 +497,7 @@ getBlockHistory db blockHeader d = do [SInt s,SInt e] [RInt,RText,RBlob] forM r $ \case - [SInt txid, SText key, SBlob value] -> (key,fromIntegral txid,) <$> Pact5.toTxLog (asString d) key value + [SInt txid, SText key, SBlob value] -> (key,fromIntegral txid,) <$> Pact5.toTxLog (Pact5.renderDomain d) key value err -> internalError $ "queryHistory: Expected single row with three columns as the \ \result, got: " <> T.pack (show err) @@ -512,9 +513,10 @@ getBlockHistory db blockHeader d = do [RBlob] case r of [] -> return Nothing - [[SBlob value]] -> Just . (RowKey $ T.decodeUtf8 sk,) <$> Pact5.toTxLog (asString d) k value + [[SBlob value]] -> Just . (RowKey $ T.decodeUtf8 sk,) <$> Pact5.toTxLog (Pact5.renderDomain d) k value _ -> internalError $ "queryPrev: expected 0 or 1 rows, got: " <> T.pack (show r) +-- TODO: do this in ChainwebPactDb instead? lookupHistorical :: SQLiteEnv -> BlockHeader @@ -528,12 +530,12 @@ lookupHistorical db blockHeader d k = do where queryHistoryLookup :: Int64 -> IO (Maybe (Pact5.TxLog Pact5.RowData)) queryHistoryLookup e = do - let sql = "SELECT rowKey, rowdata FROM [" <> domainTableNameCore d <> + let sql = "SELECT rowKey, rowdata FROM [" <> Pact5.domainTableName d <> "] WHERE txid < ? AND rowkey = ? ORDER BY txid DESC LIMIT 1;" r <- qry db sql - [SInt e, SText (convRowKeyCore k)] + [SInt e, SText (Pact5.convRowKey k)] [RText, RBlob] case r of - [[SText key, SBlob value]] -> Just <$> Pact5.toTxLog (asString d) key value + [[SText key, SBlob value]] -> Just <$> Pact5.toTxLog (Pact5.renderDomain d) key value [] -> pure Nothing _ -> internalError $ "lookupHistorical: expected single-row result, got " <> sshow r diff --git a/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs index 5c1e13716..3e34ed978 100644 --- a/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs @@ -24,15 +24,10 @@ module Chainweb.Pact4.Backend.ChainwebPactDb ( chainwebPactDb , rewoundPactDb -, rewindDbTo -, rewindDbToBlock -, commitBlockStateToDatabase , initSchema , indexPactTransaction , vacuumDb , toTxLog -, getEndTxId -, getEndTxId' , CurrentBlockDbEnv(..) , cpPactDbEnv , cpRegisterProcessedTx @@ -56,6 +51,13 @@ module Chainweb.Pact4.Backend.ChainwebPactDb , blockHandlerLowerCaseTables , blockHandlerPersistIntraBlockWrites , mkBlockHandlerEnv + +, domainTableName +, convKeySetName +, convModuleName +, convNamespaceName +, convRowKey +, convPactId ) where import Control.Applicative @@ -73,7 +75,6 @@ import Data.List(sort) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import qualified Data.HashMap.Strict as HashMap -import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import qualified Data.Map.Strict as M import Data.Maybe @@ -93,7 +94,7 @@ import Pact.PersistPactDb hiding (db) import Pact.Types.Persistence import Pact.Types.RowData import Pact.Types.SQLite -import Pact.Types.Term (ModuleName(..), ObjectMap(..), TableName(..)) +import Pact.Types.Term (ModuleName(..), ObjectMap(..), TableName(..), KeySetName(..), NamespaceName(..), PactId(..)) import Pact.Types.Util (AsString(..)) import qualified Pact.JSON.Encode as J @@ -102,14 +103,12 @@ import qualified Pact.JSON.Legacy.HashMap as LHM -- chainweb import Chainweb.BlockHash -import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Pact.Backend.DbCache import Chainweb.Pact.Backend.Utils import Chainweb.Pact.Types import Chainweb.Utils -import Chainweb.Utils.Serialization import Chainweb.Version import Pact.Interpreter (PactDbEnv) import Data.HashMap.Strict (HashMap) @@ -120,6 +119,29 @@ import Control.Exception.Safe import Pact.Types.Command (RequestKey) import Chainweb.Pact.Backend.Types +domainTableName :: Domain k v -> SQ3.Utf8 +domainTableName = asStringUtf8 + +convKeySetName :: KeySetName -> SQ3.Utf8 +convKeySetName = toUtf8 . asString + +convModuleName + :: Bool + -- ^ whether to apply module name fix + -> ModuleName + -> SQ3.Utf8 +convModuleName False (ModuleName name _) = toUtf8 name +convModuleName True mn = asStringUtf8 mn + +convNamespaceName :: NamespaceName -> SQ3.Utf8 +convNamespaceName (NamespaceName name) = toUtf8 name + +convRowKey :: RowKey -> SQ3.Utf8 +convRowKey (RowKey name) = toUtf8 name + +convPactId :: PactId -> SQ3.Utf8 +convPactId = toUtf8 . sshow + callDb :: (MonadCatch m, MonadReader (BlockHandlerEnv logger) m, MonadIO m) => T.Text @@ -761,136 +783,6 @@ indexPactTransaction :: BS.ByteString -> BlockHandler logger () indexPactTransaction h = modify' $ over (bsPendingBlock . pendingSuccessfulTxs) $ HashSet.insert h --- | Delete any state from the database newer than the input parent header. --- Returns the ending txid of the input parent header. -rewindDbTo - :: SQLiteEnv - -> Maybe ParentHeader - -> IO TxId -rewindDbTo db Nothing = do - rewindDbToGenesis db - return 0 -rewindDbTo db mh@(Just (ParentHeader ph)) = do - !historicalEndingTxId <- getEndTxId "rewindDbToBlock" db mh - endingTxId <- case historicalEndingTxId of - NoHistory -> - throwM - $ BlockHeaderLookupFailure - $ "rewindDbTo.getEndTxId: not in db: " - <> sshow ph - Historical endingTxId -> - return endingTxId - rewindDbToBlock db (view blockHeight ph) endingTxId - return endingTxId - --- rewind before genesis, delete all user tables and all rows in all tables -rewindDbToGenesis - :: SQLiteEnv - -> IO () -rewindDbToGenesis db = do - exec_ db "DELETE FROM BlockHistory;" - exec_ db "DELETE FROM [SYS:KeySets];" - exec_ db "DELETE FROM [SYS:Modules];" - exec_ db "DELETE FROM [SYS:Namespaces];" - exec_ db "DELETE FROM [SYS:Pacts];" - exec_ db "DELETE FROM [SYS:ModuleSources];" - tblNames <- qry_ db "SELECT tablename FROM VersionedTableCreation;" [RText] - forM_ tblNames $ \t -> case t of - [SText tn] -> exec_ db ("DROP TABLE [" <> tn <> "];") - _ -> internalError "Something went wrong when resetting tables." - exec_ db "DELETE FROM VersionedTableCreation;" - exec_ db "DELETE FROM VersionedTableMutation;" - exec_ db "DELETE FROM TransactionIndex;" - --- | Rewind the database to a particular block, given the end tx id of that --- block. -rewindDbToBlock - :: Database - -> BlockHeight - -> TxId - -> IO () -rewindDbToBlock db bh endingTxId = do - tableMaintenanceRowsVersionedSystemTables - droppedtbls <- dropTablesAtRewind - vacuumTablesAtRewind droppedtbls - deleteHistory - clearTxIndex - where - dropTablesAtRewind :: IO (HashSet BS.ByteString) - dropTablesAtRewind = do - toDropTblNames <- qry db findTablesToDropStmt - [SInt (fromIntegral bh)] [RText] - tbls <- fmap HashSet.fromList . forM toDropTblNames $ \case - [SText tblname@(Utf8 tn)] -> do - exec_ db $ "DROP TABLE IF EXISTS " <> tbl tblname - return tn - _ -> internalError rewindmsg - exec' db - "DELETE FROM VersionedTableCreation WHERE createBlockheight > ?" - [SInt (fromIntegral bh)] - return tbls - findTablesToDropStmt = - "SELECT tablename FROM VersionedTableCreation WHERE createBlockheight > ?;" - rewindmsg = - "rewindBlock: dropTablesAtRewind: Couldn't resolve the name of the table to drop." - - deleteHistory :: IO () - deleteHistory = - exec' db "DELETE FROM BlockHistory WHERE blockheight > ?" - [SInt (fromIntegral bh)] - - vacuumTablesAtRewind :: HashSet BS.ByteString -> IO () - vacuumTablesAtRewind droppedtbls = do - let processMutatedTables ms = fmap HashSet.fromList . forM ms $ \case - [SText (Utf8 tn)] -> return tn - _ -> internalError "rewindBlock: vacuumTablesAtRewind: Couldn't resolve the name \ - \of the table to possibly vacuum." - mutatedTables <- qry db - "SELECT DISTINCT tablename FROM VersionedTableMutation WHERE blockheight > ?;" - [SInt (fromIntegral bh)] - [RText] - >>= processMutatedTables - let toVacuumTblNames = HashSet.difference mutatedTables droppedtbls - forM_ toVacuumTblNames $ \tblname -> - exec' db ("DELETE FROM " <> tbl (Utf8 tblname) <> " WHERE txid >= ?") - [SInt $! fromIntegral endingTxId] - exec' db "DELETE FROM VersionedTableMutation WHERE blockheight > ?;" - [SInt (fromIntegral bh)] - - tableMaintenanceRowsVersionedSystemTables :: IO () - tableMaintenanceRowsVersionedSystemTables = do - exec' db "DELETE FROM [SYS:KeySets] WHERE txid >= ?" tx - exec' db "DELETE FROM [SYS:Modules] WHERE txid >= ?" tx - exec' db "DELETE FROM [SYS:Namespaces] WHERE txid >= ?" tx - exec' db "DELETE FROM [SYS:Pacts] WHERE txid >= ?" tx - exec' db "DELETE FROM [SYS:ModuleSources] WHERE txid >= ?" tx - where - tx = [SInt $! fromIntegral endingTxId] - - -- | Delete all future transactions from the index - clearTxIndex :: IO () - clearTxIndex = - exec' db "DELETE FROM TransactionIndex WHERE blockheight > ?;" - [ SInt (fromIntegral bh) ] - - -getEndTxId :: Text -> SQLiteEnv -> Maybe ParentHeader -> IO (Historical TxId) -getEndTxId msg sql pc = case pc of - Nothing -> return (Historical 0) - Just (ParentHeader ph) -> getEndTxId' msg sql (view blockHeight ph) (view blockHash ph) - -getEndTxId' :: Text -> SQLiteEnv -> BlockHeight -> BlockHash -> IO (Historical TxId) -getEndTxId' msg sql bh bhsh = do - r <- qry sql - "SELECT endingtxid FROM BlockHistory WHERE blockheight = ? and hash = ?;" - [ SInt $ fromIntegral bh - , SBlob $ runPutS (encodeBlockHash bhsh) - ] - [RInt] - case r of - [[SInt tid]] -> return $ Historical (TxId (fromIntegral tid)) - [] -> return NoHistory - _ -> internalError $ msg <> ".getEndTxId: expected single-row int result, got " <> sshow r -- | Careful doing this! It's expensive and for our use case, probably pointless. -- We should reserve vacuuming for an offline process diff --git a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs index c6bdc7ac9..59c7389cf 100644 --- a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs @@ -19,15 +19,15 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Chainweb.Pact5.Backend.ChainwebPactDb - ( chainwebPactCoreBlockDb + ( chainwebPactBlockDb , Pact5Db(..) , BlockHandlerEnv(..) , blockHandlerDb , blockHandlerLogger , toTxLog , toPactTxLog - , getEndTxId - , getEndTxId' + , domainTableName + , convRowKey ) where import Data.Coerce @@ -55,8 +55,7 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T -- import Data.Default - -import Database.SQLite3.Direct +import qualified Database.SQLite3.Direct as SQ3 import GHC.Stack @@ -67,17 +66,16 @@ import Prelude hiding (concat, log) import qualified Pact.JSON.Legacy.HashMap as LHM import qualified Pact.Types.Persistence as Pact4 import Pact.Types.SQLite hiding (liftEither) -import Pact.Types.Util (AsString(..)) -import Pact.Core.Evaluate -import Pact.Core.Persistence as PCore -import Pact.Core.Serialise -import Pact.Core.Names -import Pact.Core.Builtin -import Pact.Core.Guards -import Pact.Core.Errors -import Pact.Core.Gas +import qualified Pact.Core.Evaluate as Pact +import qualified Pact.Core.Guards as Pact +import qualified Pact.Core.Names as Pact +import qualified Pact.Core.Persistence as Pact +import qualified Pact.Core.Serialise as Pact +import qualified Pact.Core.Builtin as Pact +import qualified Pact.Core.Errors as Pact +import qualified Pact.Core.Gas as Pact -- chainweb @@ -90,16 +88,10 @@ import Chainweb.Utils (sshow, T2) import Pact.Core.StableEncoding (encodeStable) import Data.Text (Text) import Chainweb.Version -import qualified Pact.Core.Persistence as Pact5 -import qualified Pact.Core.Builtin as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import qualified Database.SQLite3 as SQ3 import Chainweb.Version.Guards (enableModuleNameFix, chainweb217Pact, pact42) import Data.DList (DList) import Data.ByteString (ByteString) -import Chainweb.BlockHeader import Chainweb.BlockHash -import Chainweb.Utils.Serialization import Data.Vector (Vector) import qualified Data.ByteString.Short as SB import Data.HashMap.Strict (HashMap) @@ -113,7 +105,7 @@ data BlockHandlerEnv logger = BlockHandlerEnv , _blockHandlerVersion :: !ChainwebVersion , _blockHandlerBlockHeight :: !BlockHeight , _blockHandlerChainId :: !ChainId - , _blockHandlerMode :: !ExecutionMode + , _blockHandlerMode :: !Pact.ExecutionMode , _blockHandlerPersistIntraBlockWrites :: !IntraBlockPersistence } @@ -121,16 +113,16 @@ data BlockHandlerEnv logger = BlockHandlerEnv -- Includes both the state re: the whole block, and the state re: a transaction in progress. data BlockState = BlockState { _bsBlockHandle :: !BlockHandle - , _bsPendingTx :: !(Maybe (SQLitePendingData, DList (Pact5.TxLog ByteString))) + , _bsPendingTx :: !(Maybe (SQLitePendingData, DList (Pact.TxLog ByteString))) } makeLenses ''BlockState makeLenses ''BlockHandlerEnv -getPendingTxOrError :: Text -> BlockHandler logger (SQLitePendingData, DList (Pact5.TxLog ByteString)) +getPendingTxOrError :: Text -> BlockHandler logger (SQLitePendingData, DList (Pact.TxLog ByteString)) getPendingTxOrError msg = do use bsPendingTx >>= \case - Nothing -> liftGas $ throwDbOpErrorGasM (NotInTx msg) + Nothing -> liftGas $ Pact.throwDbOpErrorGasM (Pact.NotInTx msg) Just t -> return t -- | The Pact 5 database as it's provided by the checkpointer. @@ -139,7 +131,7 @@ data Pact5Db = Pact5Db :: forall a . BlockHandle -> Maybe RequestKey - -> (Pact5.PactDb Pact5.CoreBuiltin Pact5.Info -> IO a) + -> (Pact.PactDb Pact.CoreBuiltin Pact.Info -> IO a) -> IO (a, BlockHandle) -- ^ Give this function a BlockHandle representing the state of a block so far, -- and it will allow you to access a PactDb which contains the Pact state @@ -158,7 +150,7 @@ type instance PactDbFor logger Pact5 = Pact5Db newtype BlockHandler logger a = BlockHandler { runBlockHandler :: ReaderT (BlockHandlerEnv logger) - (StateT BlockState (GasM CoreBuiltin Info)) a + (StateT BlockState (Pact.GasM Pact.CoreBuiltin Pact.Info)) a } deriving newtype ( Functor , Applicative @@ -181,6 +173,37 @@ callDb callerName action = do Left err -> internalDbError $ "callDb (" <> callerName <> "): " <> sshow err Right r -> return r +domainTableName :: Pact.Domain k v b i -> SQ3.Utf8 +domainTableName = toUtf8 . Pact.renderDomain + +tableName :: Pact.TableName -> SQ3.Utf8 +tableName = toUtf8 . Pact.renderTableName + +convKeySetName :: Pact.KeySetName -> SQ3.Utf8 +convKeySetName = toUtf8 . Pact.renderKeySetName + +convModuleName + :: Bool + -- ^ whether to apply module name fix + -> Pact.ModuleName + -> SQ3.Utf8 +convModuleName False (Pact.ModuleName name _) = toUtf8 name +convModuleName True mn = toUtf8 $ Pact.renderModuleName mn + +convNamespaceName :: Pact.NamespaceName -> SQ3.Utf8 +convNamespaceName (Pact.NamespaceName name) = toUtf8 name + +convRowKey :: Pact.RowKey -> SQ3.Utf8 +convRowKey (Pact.RowKey name) = toUtf8 name + +-- to match legacy keys +convPactId :: Pact.DefPactId -> SQ3.Utf8 +convPactId pid = "PactId \"" <> toUtf8 (Pact.renderDefPactId pid) <> "\"" + +convHashedModuleName :: Pact.HashedModuleName -> SQ3.Utf8 +convHashedModuleName = toUtf8 . Pact.renderHashedModuleName + + newtype InternalDbException = InternalDbException Text deriving newtype (Eq) deriving stock (Show) @@ -189,45 +212,48 @@ newtype InternalDbException = InternalDbException Text internalDbError :: MonadThrow m => Text -> m a internalDbError = throwM . InternalDbException -liftGas :: GasM CoreBuiltin Info a -> BlockHandler logger a +liftGas :: Pact.GasM Pact.CoreBuiltin Pact.Info a -> BlockHandler logger a liftGas g = BlockHandler (lift (lift g)) -runOnBlockGassed :: BlockHandlerEnv logger -> MVar BlockState -> BlockHandler logger a -> GasM CoreBuiltin Info a +runOnBlockGassed + :: BlockHandlerEnv logger -> MVar BlockState + -> BlockHandler logger a + -> Pact.GasM Pact.CoreBuiltin Pact.Info a runOnBlockGassed env stateVar act = do ge <- ask r <- liftIO $ modifyMVar stateVar $ \s -> do - r <- runExceptT (runReaderT (runGasM (runStateT (runReaderT (runBlockHandler act) env) s)) ge) + r <- runExceptT (runReaderT (Pact.runGasM (runStateT (runReaderT (runBlockHandler act) env) s)) ge) let newState = either (\_ -> s) snd r return (newState, fmap fst r) liftEither r -chainwebPactCoreBlockDb :: (Logger logger) => Maybe (BlockHeight, TxId) -> BlockHandlerEnv logger -> Pact5Db -chainwebPactCoreBlockDb maybeLimit env = Pact5Db +chainwebPactBlockDb :: (Logger logger) => Maybe (BlockHeight, Pact.TxId) -> BlockHandlerEnv logger -> Pact5Db +chainwebPactBlockDb maybeLimit env = Pact5Db { doPact5DbTransaction = \blockHandle maybeRequestKey kont -> do stateVar <- newMVar $ BlockState blockHandle Nothing - let basePactDb = PactDb - { _pdbPurity = PImpure - , _pdbRead = \d k -> runOnBlockGassed env stateVar $ doReadRow Nothing d k - , _pdbWrite = \wt d k v -> + let basePactDb = Pact.PactDb + { Pact._pdbPurity = Pact.PImpure + , Pact._pdbRead = \d k -> runOnBlockGassed env stateVar $ doReadRow Nothing d k + , Pact._pdbWrite = \wt d k v -> runOnBlockGassed env stateVar $ doWriteRow Nothing wt d k v - , _pdbKeys = \d -> + , Pact._pdbKeys = \d -> runOnBlockGassed env stateVar $ doKeys Nothing d - , _pdbCreateUserTable = \tn -> + , Pact._pdbCreateUserTable = \tn -> runOnBlockGassed env stateVar $ doCreateUserTable Nothing tn - , _pdbBeginTx = \m -> + , Pact._pdbBeginTx = \m -> runOnBlockGassed env stateVar $ doBegin m - , _pdbCommitTx = + , Pact._pdbCommitTx = runOnBlockGassed env stateVar doCommit - , _pdbRollbackTx = + , Pact._pdbRollbackTx = runOnBlockGassed env stateVar doRollback } let maybeLimitedPactDb = case maybeLimit of Just (bh, endTxId) -> basePactDb - { _pdbRead = \d k -> runOnBlockGassed env stateVar $ doReadRow (Just (bh, endTxId)) d k - , _pdbWrite = \wt d k v -> do + { Pact._pdbRead = \d k -> runOnBlockGassed env stateVar $ doReadRow (Just (bh, endTxId)) d k + , Pact._pdbWrite = \wt d k v -> do runOnBlockGassed env stateVar $ doWriteRow (Just (bh, endTxId)) wt d k v - , _pdbKeys = \d -> runOnBlockGassed env stateVar $ doKeys (Just (bh, endTxId)) d - , _pdbCreateUserTable = \tn -> do + , Pact._pdbKeys = \d -> runOnBlockGassed env stateVar $ doKeys (Just (bh, endTxId)) d + , Pact._pdbCreateUserTable = \tn -> do runOnBlockGassed env stateVar $ doCreateUserTable (Just bh) tn } Nothing -> basePactDb @@ -264,7 +290,7 @@ forModuleNameFix f = do f (enableModuleNameFix v cid bh) -- TODO: speed this up, cache it? -tableExistsInDbAtHeight :: Utf8 -> BlockHeight -> BlockHandler logger Bool +tableExistsInDbAtHeight :: SQ3.Utf8 -> BlockHeight -> BlockHandler logger Bool tableExistsInDbAtHeight tablename bh = do let knownTbls = ["SYS:Pacts", "SYS:Modules", "SYS:KeySets", "SYS:Namespaces", "SYS:ModuleSources"] @@ -279,35 +305,35 @@ tableExistsInDbAtHeight tablename bh = do _ -> return True doReadRow - :: Maybe (BlockHeight, TxId) + :: Maybe (BlockHeight, Pact.TxId) -- ^ the highest block we should be reading writes from - -> Domain k v CoreBuiltin Info + -> Pact.Domain k v Pact.CoreBuiltin Pact.Info -> k -> BlockHandler logger (Maybe v) doReadRow mlim d k = forModuleNameFix $ \mnFix -> case d of - DKeySets -> let f = (\v -> (view document <$> _decodeKeySet serialisePact_lineinfo v)) in - lookupWithKey (convKeySetNameCore k) f (noCache f) + Pact.DKeySets -> let f = (\v -> (view Pact.document <$> Pact._decodeKeySet Pact.serialisePact_lineinfo v)) in + lookupWithKey (convKeySetName k) f (noCache f) -- TODO: This is incomplete (the modules case), due to namespace -- resolution concerns - DModules -> let f = (\v -> (view document <$> _decodeModuleData serialisePact_lineinfo v)) in - lookupWithKey (convModuleNameCore mnFix k) f (noCacheChargeModuleSize f) - DNamespaces -> let f = (\v -> (view document <$> _decodeNamespace serialisePact_lineinfo v)) in - lookupWithKey (convNamespaceNameCore k) f (noCache f) - DUserTables _ -> let f = (\v -> (view document <$> _decodeRowData serialisePact_lineinfo v)) in - lookupWithKey (convRowKeyCore k) f (noCache f) - DDefPacts -> let f = (\v -> (view document <$> _decodeDefPactExec serialisePact_lineinfo v)) in - lookupWithKey (convPactIdCore k) f (noCache f) - DModuleSource -> let f = (\v -> (view document <$> _decodeModuleCode serialisePact_lineinfo v)) in + Pact.DModules -> let f = (\v -> (view Pact.document <$> Pact._decodeModuleData Pact.serialisePact_lineinfo v)) in + lookupWithKey (convModuleName mnFix k) f (noCacheChargeModuleSize f) + Pact.DNamespaces -> let f = (\v -> (view Pact.document <$> Pact._decodeNamespace Pact.serialisePact_lineinfo v)) in + lookupWithKey (convNamespaceName k) f (noCache f) + Pact.DUserTables _ -> let f = (\v -> (view Pact.document <$> Pact._decodeRowData Pact.serialisePact_lineinfo v)) in + lookupWithKey (convRowKey k) f (noCache f) + Pact.DDefPacts -> let f = (\v -> (view Pact.document <$> Pact._decodeDefPactExec Pact.serialisePact_lineinfo v)) in + lookupWithKey (convPactId k) f (noCache f) + Pact.DModuleSource -> let f = (\v -> (view Pact.document <$> Pact._decodeModuleCode Pact.serialisePact_lineinfo v)) in lookupWithKey (convHashedModuleName k) f (noCache f) where - tablename@(Utf8 tableNameBS) = domainTableNameCore d + tablename@(SQ3.Utf8 tableNameBS) = domainTableName d lookupWithKey :: forall logger v . - Utf8 + SQ3.Utf8 -> (BS.ByteString -> Maybe v) - -> (Utf8 -> BS.ByteString -> MaybeT (BlockHandler logger) v) + -> (SQ3.Utf8 -> BS.ByteString -> MaybeT (BlockHandler logger) v) -> BlockHandler logger (Maybe v) lookupWithKey key f checkCache = do pds <- getPendingData "read" @@ -317,11 +343,11 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> lookupInPendingData :: forall logger v . - Utf8 + SQ3.Utf8 -> (BS.ByteString -> Maybe v) -> SQLitePendingData -> MaybeT (BlockHandler logger) v - lookupInPendingData (Utf8 rowkey) f p = do + lookupInPendingData (SQ3.Utf8 rowkey) f p = do -- we get the latest-written value at this rowkey allKeys <- hoistMaybe $ HashMap.lookup tableNameBS (_pendingWrites p) ddata <- _deltaData . NE.head <$> hoistMaybe (HashMap.lookup rowkey allKeys) @@ -329,9 +355,9 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> lookupInDb :: forall logger v . - Utf8 + SQ3.Utf8 -> (BS.ByteString -> Maybe v) - -> (Utf8 -> BS.ByteString -> MaybeT (BlockHandler logger) v) + -> (SQ3.Utf8 -> BS.ByteString -> MaybeT (BlockHandler logger) v) -> MaybeT (BlockHandler logger) v lookupInDb rowkey _ checkCache = do -- First, check: did we create this table during this block? If so, @@ -341,7 +367,7 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> failIfTableDoesNotExistInDbAtHeight "doReadRow" tablename bh -- we inject the endingtx limitation to reduce the scope up to the provided block height let blockLimitStmt = maybe "" (const " AND txid < ?") mlim - let blockLimitParam = maybe [] (\(TxId txid) -> [SInt $ fromIntegral txid]) (snd <$> mlim) + let blockLimitParam = maybe [] (\(Pact.TxId txid) -> [SInt $ fromIntegral txid]) (snd <$> mlim) let queryStmt = "SELECT rowdata FROM " <> tbl tablename <> " WHERE rowkey = ?" <> blockLimitStmt <> " ORDER BY txid DESC LIMIT 1;" @@ -356,56 +382,56 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> noCache :: (BS.ByteString -> Maybe v) - -> Utf8 + -> SQ3.Utf8 -> BS.ByteString -> MaybeT (BlockHandler logger) v noCache f _key rowdata = MaybeT $ return $! f rowdata noCacheChargeModuleSize - :: (BS.ByteString -> Maybe (ModuleData CoreBuiltin Info)) - -> Utf8 + :: (BS.ByteString -> Maybe (Pact.ModuleData Pact.CoreBuiltin Pact.Info)) + -> SQ3.Utf8 -> BS.ByteString - -> MaybeT (BlockHandler logger) (ModuleData CoreBuiltin Info) + -> MaybeT (BlockHandler logger) (Pact.ModuleData Pact.CoreBuiltin Pact.Info) noCacheChargeModuleSize f _key rowdata = do - lift $ BlockHandler $ lift $ lift (chargeGasM (GModuleOp (MOpLoadModule (BS.length rowdata)))) + lift $ BlockHandler $ lift $ lift (Pact.chargeGasM (Pact.GModuleOp (Pact.MOpLoadModule (BS.length rowdata)))) MaybeT $ return $! f rowdata -checkDbTablePendingCreation :: Text -> Utf8 -> MaybeT (BlockHandler logger) () -checkDbTablePendingCreation msg (Utf8 tablename) = do +checkDbTablePendingCreation :: Text -> SQ3.Utf8 -> MaybeT (BlockHandler logger) () +checkDbTablePendingCreation msg (SQ3.Utf8 tablename) = do pds <- lift (getPendingData msg) forM_ pds $ \p -> when (HashSet.member tablename (_pendingTableCreation p)) mzero -latestTxId :: Lens' BlockState TxId +latestTxId :: Lens' BlockState Pact.TxId latestTxId = bsBlockHandle . blockHandleTxId . coerced writeSys - :: Domain k v CoreBuiltin Info + :: Pact.Domain k v Pact.CoreBuiltin Pact.Info -> k -> v -> BlockHandler logger () writeSys d k v = do txid <- use latestTxId (kk, vv) <- forModuleNameFix $ \mnFix -> pure $ case d of - DKeySets -> (convKeySetNameCore k, _encodeKeySet serialisePact_lineinfo v) - DModules -> (convModuleNameCore mnFix k, _encodeModuleData serialisePact_lineinfo v) - DNamespaces -> (convNamespaceNameCore k, _encodeNamespace serialisePact_lineinfo v) - DDefPacts -> (convPactIdCore k, _encodeDefPactExec serialisePact_lineinfo v) - DUserTables _ -> error "impossible" - DModuleSource -> (convHashedModuleName k, _encodeModuleCode serialisePact_lineinfo v) + Pact.DKeySets -> (convKeySetName k, Pact._encodeKeySet Pact.serialisePact_lineinfo v) + Pact.DModules -> (convModuleName mnFix k, Pact._encodeModuleData Pact.serialisePact_lineinfo v) + Pact.DNamespaces -> (convNamespaceName k, Pact._encodeNamespace Pact.serialisePact_lineinfo v) + Pact.DDefPacts -> (convPactId k, Pact._encodeDefPactExec Pact.serialisePact_lineinfo v) + Pact.DUserTables _ -> error "impossible" + Pact.DModuleSource -> (convHashedModuleName k, Pact._encodeModuleCode Pact.serialisePact_lineinfo v) recordPendingUpdate kk (toUtf8 tablename) txid vv recordTxLog d kk vv where - tablename = asString d + tablename = Pact.renderDomain d recordPendingUpdate - :: Utf8 - -> Utf8 - -> PCore.TxId + :: SQ3.Utf8 + -> SQ3.Utf8 + -> Pact.TxId -> BS.ByteString -> BlockHandler logger () -recordPendingUpdate (Utf8 key) (Utf8 tn) txid vs = modifyPendingData "write" modf +recordPendingUpdate (SQ3.Utf8 key) (SQ3.Utf8 tn) txid vs = modifyPendingData "write" modf where delta = SQLiteRowDelta tn (coerce txid) key vs @@ -416,73 +442,73 @@ recordPendingUpdate (Utf8 key) (Utf8 tn) txid vs = modifyPendingData "write" mod (HashMap.singleton key (NE.singleton delta))) checkInsertIsOK - :: Maybe (BlockHeight, TxId) - -> TableName + :: Maybe (BlockHeight, Pact.TxId) + -> Pact.TableName -- ^ the highest block we should be reading writes from - -> WriteType - -> Domain RowKey RowData CoreBuiltin Info - -> RowKey - -> BlockHandler logger (Maybe RowData) + -> Pact.WriteType + -> Pact.Domain Pact.RowKey Pact.RowData Pact.CoreBuiltin Pact.Info + -> Pact.RowKey + -> BlockHandler logger (Maybe Pact.RowData) checkInsertIsOK mlim tn wt d k = do olds <- doReadRow mlim d k case (olds, wt) of - (Nothing, Insert) -> return Nothing - (Just _, Insert) -> liftGas $ throwDbOpErrorGasM (RowFoundError tn k) - (Nothing, Write) -> return Nothing - (Just old, Write) -> return $ Just old - (Just old, Update) -> return $ Just old - (Nothing, Update) -> liftGas $ throwDbOpErrorGasM (NoRowFound tn k) + (Nothing, Pact.Insert) -> return Nothing + (Just _, Pact.Insert) -> liftGas $ Pact.throwDbOpErrorGasM (Pact.RowFoundError tn k) + (Nothing, Pact.Write) -> return Nothing + (Just old, Pact.Write) -> return $ Just old + (Just old, Pact.Update) -> return $ Just old + (Nothing, Pact.Update) -> liftGas $ Pact.throwDbOpErrorGasM (Pact.NoRowFound tn k) writeUser - :: Maybe (BlockHeight, TxId) + :: Maybe (BlockHeight, Pact.TxId) -- ^ the highest block we should be reading writes from - -> WriteType - -> Domain RowKey RowData CoreBuiltin Info - -> RowKey - -> RowData + -> Pact.WriteType + -> Pact.Domain Pact.RowKey Pact.RowData Pact.CoreBuiltin Pact.Info + -> Pact.RowKey + -> Pact.RowData -> BlockHandler logger () -writeUser mlim wt d k rowdata@(RowData row) = do - Pact5.TxId txid <- use latestTxId - let (DUserTables tname) = d +writeUser mlim wt d k rowdata@(Pact.RowData row) = do + Pact.TxId txid <- use latestTxId + let (Pact.DUserTables tname) = d m <- checkInsertIsOK mlim tname wt d k row' <- case m of Nothing -> ins txid Just old -> upd txid old - liftGas (_encodeRowData serialisePact_lineinfo row') >>= - \encoded -> recordTxLog d (convRowKeyCore k) encoded + liftGas (Pact._encodeRowData Pact.serialisePact_lineinfo row') >>= + \encoded -> recordTxLog d (convRowKey k) encoded where - tn = asString d + tn = Pact.renderDomain d - upd txid (RowData oldrow) = do - let row' = RowData (M.union row oldrow) - liftGas (_encodeRowData serialisePact_lineinfo row') >>= + upd txid (Pact.RowData oldrow) = do + let row' = Pact.RowData (M.union row oldrow) + liftGas (Pact._encodeRowData Pact.serialisePact_lineinfo row') >>= \encoded -> do - recordPendingUpdate (convRowKeyCore k) (toUtf8 tn) (PCore.TxId txid) encoded + recordPendingUpdate (convRowKey k) (toUtf8 tn) (Pact.TxId txid) encoded return row' ins txid = do - liftGas (_encodeRowData serialisePact_lineinfo rowdata) >>= + liftGas (Pact._encodeRowData Pact.serialisePact_lineinfo rowdata) >>= \encoded -> do - recordPendingUpdate (convRowKeyCore k) (toUtf8 tn) (PCore.TxId txid) encoded + recordPendingUpdate (convRowKey k) (toUtf8 tn) (Pact.TxId txid) encoded return rowdata doWriteRow - :: Maybe (BlockHeight, TxId) + :: Maybe (BlockHeight, Pact.TxId) -- ^ the highest block we should be reading writes from - -> WriteType - -> Domain k v CoreBuiltin Info + -> Pact.WriteType + -> Pact.Domain k v Pact.CoreBuiltin Pact.Info -> k -> v -> BlockHandler logger () doWriteRow mlim wt d k v = case d of - (DUserTables _) -> writeUser mlim wt d k v + (Pact.DUserTables _) -> writeUser mlim wt d k v _ -> writeSys d k v doKeys :: forall k v logger . - Maybe (BlockHeight, TxId) + Maybe (BlockHeight, Pact.TxId) -- ^ the highest block we should be reading writes from - -> Domain k v CoreBuiltin Info + -> Pact.Domain k v Pact.CoreBuiltin Pact.Info -> BlockHandler logger [k] doKeys mlim d = do msort <- asks $ \e -> @@ -500,28 +526,28 @@ doKeys mlim d = do $ LHM.sort $ dbKeys ++ memKeys case d of - DKeySets -> do - let parsed = map parseAnyKeysetName allKeys + Pact.DKeySets -> do + let parsed = map Pact.parseAnyKeysetName allKeys case sequence parsed of Left msg -> internalDbError $ "doKeys.DKeySets: unexpected decoding " <> T.pack msg Right v -> pure v - DModules -> do - let parsed = map parseModuleName allKeys + Pact.DModules -> do + let parsed = map Pact.parseModuleName allKeys case sequence parsed of Nothing -> internalDbError $ "doKeys.DModules: unexpected decoding" Just v -> pure v - DNamespaces -> pure $ map NamespaceName allKeys - DDefPacts -> pure $ map DefPactId allKeys - DUserTables _ -> pure $ map RowKey allKeys - DModuleSource -> do - let parsed = map parseHashedModuleName allKeys + Pact.DNamespaces -> pure $ map Pact.NamespaceName allKeys + Pact.DDefPacts -> pure $ map Pact.DefPactId allKeys + Pact.DUserTables _ -> pure $ map Pact.RowKey allKeys + Pact.DModuleSource -> do + let parsed = map Pact.parseHashedModuleName allKeys case sequence parsed of Just v -> pure v Nothing -> internalDbError $ "doKeys.DModuleSources: unexpected decoding" where blockLimitStmt = maybe "" (const " WHERE txid < ?;") mlim - blockLimitParam = maybe [] (\(TxId txid) -> [SInt (fromIntegral txid)]) (snd <$> mlim) + blockLimitParam = maybe [] (\(Pact.TxId txid) -> [SInt (fromIntegral txid)]) (snd <$> mlim) getDbKeys = do m <- runMaybeT $ checkDbTablePendingCreation "keys" tn @@ -536,12 +562,12 @@ doKeys mlim d = do [SText k] -> return $ fromUtf8 k _ -> internalDbError "doKeys: The impossible happened." - tn@(Utf8 tnBS) = asStringUtf8 d + tn@(SQ3.Utf8 tnBS) = toUtf8 $ Pact.renderDomain d collect p = concatMap NE.toList $ HashMap.elems $ fromMaybe mempty $ HashMap.lookup tnBS (_pendingWrites p) failIfTableDoesNotExistInDbAtHeight - :: T.Text -> Utf8 -> BlockHeight -> BlockHandler logger () + :: T.Text -> SQ3.Utf8 -> BlockHeight -> BlockHandler logger () failIfTableDoesNotExistInDbAtHeight caller tn bh = do exists <- tableExistsInDbAtHeight tn bh -- we must reproduce errors that were thrown in earlier blocks from tables @@ -550,25 +576,25 @@ failIfTableDoesNotExistInDbAtHeight caller tn bh = do internalDbError $ "callDb (" <> caller <> "): user error (Database error: ErrorError)" recordTxLog - :: Domain k v CoreBuiltin Info - -> Utf8 + :: Pact.Domain k v Pact.CoreBuiltin Pact.Info + -> SQ3.Utf8 -> BS.ByteString -> BlockHandler logger () -recordTxLog d (Utf8 k) v = do +recordTxLog d (SQ3.Utf8 k) v = do -- are we in a tx? if not, error. (pendingSQLite, txlogs) <- getPendingTxOrError "write" modify' (bsPendingTx .~ Just (pendingSQLite, DL.snoc txlogs newLog)) where - !newLog = TxLog (renderDomain d) (T.decodeUtf8 k) v + !newLog = Pact.TxLog (Pact.renderDomain d) (T.decodeUtf8 k) v -recordTableCreationTxLog :: TableName -> BlockHandler logger () +recordTableCreationTxLog :: Pact.TableName -> BlockHandler logger () recordTableCreationTxLog tn = do (pendingSQLite, txlogs) <- getPendingTxOrError "create table" modify' $ bsPendingTx .~ Just (pendingSQLite, DL.snoc txlogs newLog) where - !newLog = TxLog "SYS:usertables" (_tableName tn) (encodeStable uti) - !uti = UserTableInfo (_tableModuleName tn) + !newLog = Pact.TxLog "SYS:usertables" (Pact._tableName tn) (encodeStable uti) + !uti = Pact.UserTableInfo (Pact._tableModuleName tn) modifyPendingData :: Text @@ -581,14 +607,14 @@ modifyPendingData msg f = do doCreateUserTable :: Maybe BlockHeight -- ^ the highest block we should be seeing tables from - -> TableName + -> Pact.TableName -> BlockHandler logger () doCreateUserTable mbh tn = do -- first check if tablename already exists in pending queues - m <- runMaybeT $ checkDbTablePendingCreation "create table" (tableNameCore tn) + m <- runMaybeT $ checkDbTablePendingCreation "create table" (tableName tn) case m of Nothing -> - liftGas $ throwDbOpErrorGasM $ TableAlreadyExists tn + liftGas $ Pact.throwDbOpErrorGasM $ Pact.TableAlreadyExists tn Just () -> do -- then check if it is in the db lcTables <- asks $ \e -> @@ -596,12 +622,12 @@ doCreateUserTable mbh tn = do (_blockHandlerVersion e) (_blockHandlerChainId e) (_blockHandlerBlockHeight e) - cond <- inDb lcTables $ Utf8 $ T.encodeUtf8 $ asString tn + cond <- inDb lcTables $ SQ3.Utf8 $ T.encodeUtf8 $ Pact.renderTableName tn when cond $ - liftGas $ throwDbOpErrorGasM $ TableAlreadyExists tn + liftGas $ Pact.throwDbOpErrorGasM $ Pact.TableAlreadyExists tn modifyPendingData "create table" - $ over pendingTableCreation (HashSet.insert (T.encodeUtf8 $ asString tn)) + $ over pendingTableCreation (HashSet.insert (T.encodeUtf8 $ Pact.renderTableName tn)) recordTableCreationTxLog tn where inDb lcTables t = do @@ -628,12 +654,12 @@ doRollback = modify' $ set bsPendingTx Nothing -- | Commit a Pact transaction -doCommit :: BlockHandler logger [TxLog B8.ByteString] +doCommit :: BlockHandler logger [Pact.TxLog B8.ByteString] doCommit = view blockHandlerMode >>= \case m -> do - txrs <- if m == Transactional + txrs <- if m == Pact.Transactional then do - modify' $ over latestTxId (\(TxId tid) -> TxId (succ tid)) + modify' $ over latestTxId (\(Pact.TxId tid) -> Pact.TxId (succ tid)) pending <- getPendingTxOrError "commit" persistIntraBlockWrites <- view blockHandlerPersistIntraBlockWrites -- merge pending tx into pending block data @@ -659,39 +685,22 @@ doCommit = view blockHandlerMode >>= \case DoNotPersistIntraBlockWrites -> lastTxWrite :| [] -- | Begin a Pact transaction. Note that we don't actually use the ExecutionMode anymore. -doBegin :: (Logger logger) => ExecutionMode -> BlockHandler logger (Maybe TxId) +doBegin :: (Logger logger) => Pact.ExecutionMode -> BlockHandler logger (Maybe Pact.TxId) doBegin _m = do use bsPendingTx >>= \case Just _ -> do txid <- use latestTxId - liftGas $ throwDbOpErrorGasM (TxAlreadyBegun ("TxId " <> sshow (_txId txid))) + liftGas $ Pact.throwDbOpErrorGasM (Pact.TxAlreadyBegun ("TxId " <> sshow (Pact._txId txid))) Nothing -> do modify' $ set bsPendingTx (Just (emptySQLitePendingData, mempty)) Just <$> use latestTxId -toTxLog :: MonadThrow m => T.Text -> Utf8 -> BS.ByteString -> m (TxLog RowData) +toTxLog :: MonadThrow m => T.Text -> SQ3.Utf8 -> BS.ByteString -> m (Pact.TxLog Pact.RowData) toTxLog d key value = - case fmap (view document) $ _decodeRowData serialisePact_lineinfo value of + case fmap (view Pact.document) $ Pact._decodeRowData Pact.serialisePact_lineinfo value of Nothing -> internalDbError $ "toTxLog: Unexpected value, unable to deserialize log: " <> sshow value - Just v -> return $! TxLog d (fromUtf8 key) v - -toPactTxLog :: TxLog RowData -> Pact4.TxLog RowData -toPactTxLog (TxLog d k v) = Pact4.TxLog d k v - -getEndTxId :: Text -> SQLiteEnv -> Maybe ParentHeader -> IO (Historical TxId) -getEndTxId msg sql pc = case pc of - Nothing -> return (Historical (TxId 0)) - Just (ParentHeader ph) -> getEndTxId' msg sql (view blockHeight ph) (view blockHash ph) - -getEndTxId' :: Text -> SQLiteEnv -> BlockHeight -> BlockHash -> IO (Historical TxId) -getEndTxId' msg sql bh bhsh = do - qry sql - "SELECT endingtxid FROM BlockHistory WHERE blockheight = ? and hash = ?;" - [ SInt $ fromIntegral bh - , SBlob $ runPutS (encodeBlockHash bhsh) - ] - [RInt] >>= \case - [[SInt tid]] -> return $ Historical (TxId (fromIntegral tid)) - [] -> return NoHistory - r -> internalDbError $ msg <> ".getEndTxId: expected single-row int result, got " <> sshow r + Just v -> return $! Pact.TxLog d (fromUtf8 key) v + +toPactTxLog :: Pact.TxLog Pact.RowData -> Pact4.TxLog Pact.RowData +toPactTxLog (Pact.TxLog d k v) = Pact4.TxLog d k v From 41010a61405ba7bbdef9cdfd6e4d42a8bef47102 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 15:43:42 -0500 Subject: [PATCH 08/16] delete putStrLns --- src/Chainweb/Pact/PactService.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 09bed4c75..ed2e313a8 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -465,10 +465,8 @@ serviceRequests memPoolAccess reqQ = go ) case maybeException of Left (fromException -> Just AsyncCancelled) -> do - liftIO $ putStrLn "Pact action was cancelled" logDebugPact "Pact action was cancelled" Left (fromException -> Just ThreadKilled) -> do - liftIO $ putStrLn "Pact action thread was killed" logWarnPact "Pact action thread was killed" Left (exn :: SomeException) -> do logErrorPact $ mconcat From 60e11ec6d51eef1e579bfcb43fb90a7e0c568487 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 15:58:05 -0500 Subject: [PATCH 09/16] Comment that we won't need Pact 4 newblock or continueblock --- src/Chainweb/Pact/PactService.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index ed2e313a8..ff85aff27 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -493,6 +493,8 @@ execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do v <- view chainwebVersion cid <- view chainId Checkpointer.readFrom (Just newBlockParent) $ + -- TODO: after the Pact 5 fork is complete, the Pact 4 case below will + -- be unnecessary; the genesis blocks are already handled by 'execNewGenesisBlock'. SomeBlockM $ Pair (do blockDbEnv <- view psBlockDbEnv @@ -563,6 +565,8 @@ execContinueBlock execContinueBlock mpAccess blockInProgress = pactLabel "execNewBlock" $ do Checkpointer.readFrom newBlockParent $ case _blockInProgressPactVersion blockInProgress of + -- TODO: after the Pact 5 fork is complete, the Pact 4 case below will + -- be unnecessary; the genesis blocks are already handled by 'execNewGenesisBlock'. Pact4T -> SomeBlockM $ Pair (Pact4.continueBlock mpAccess blockInProgress) (error "pact5") Pact5T -> SomeBlockM $ Pair (error "pact4") (Pact5.continueBlock mpAccess blockInProgress) where From 834e18ae95cfc8726d17d76ce615c1e7fd194c2e Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 15:58:05 -0500 Subject: [PATCH 10/16] Delete comment --- src/Chainweb/Pact/PactService.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index ff85aff27..4e6c50393 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -1131,7 +1131,6 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do let result = V.map (const $ Just Mempool.InsertErrorTimedOut) txs logDebug_ logger $ "Mempool pre-insert check result: " <> sshow result pure result - --pure $ V.map (const $ Just Mempool.InsertErrorTimedOut) txs where attemptBuyGasPact4 From 5b75b6fac2d8288311d747f337656b6a3737ee8d Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 16:15:37 -0500 Subject: [PATCH 11/16] Remove type-level version tag from PactUpgrade --- src/Chainweb/Pact4/TransactionExec.hs | 14 +++++----- src/Chainweb/Pact5/TransactionExec.hs | 18 +++++++------ src/Chainweb/Rosetta/Internal.hs | 10 ++++--- src/Chainweb/Version.hs | 18 ++++++------- src/Chainweb/Version/Mainnet.hs | 30 ++++++++++----------- src/Chainweb/Version/RecapDevelopment.hs | 10 +++---- src/Chainweb/Version/Registry.hs | 6 ++--- src/Chainweb/Version/Testnet04.hs | 33 ++++++++++++------------ test/lib/Chainweb/Test/TestVersions.hs | 14 +++++----- 9 files changed, 79 insertions(+), 74 deletions(-) diff --git a/src/Chainweb/Pact4/TransactionExec.hs b/src/Chainweb/Pact4/TransactionExec.hs index a6b1f01b9..d052dbd42 100644 --- a/src/Chainweb/Pact4/TransactionExec.hs +++ b/src/Chainweb/Pact4/TransactionExec.hs @@ -808,8 +808,10 @@ applyUpgrades -> BlockHeight -> TransactionM logger p (Maybe ModuleCache) applyUpgrades v cid height - | Just (ForSomePactVersion Pact4T upg) <- - v ^? versionUpgrades . atChain cid . ix height = applyUpgrade upg + | Just Pact4Upgrade{_pact4UpgradeTransactions = txs, _legacyUpgradeIsPrecocious = isPrecocious} <- + v ^? versionUpgrades . atChain cid . ix height = applyUpgrade txs isPrecocious + | Just Pact5Upgrade{} <- + v ^? versionUpgrades . atChain cid . ix height = error "Expected Pact 4 upgrade, got Pact 5" | cleanModuleCache v cid height = filterModuleCache | otherwise = return Nothing where @@ -819,10 +821,10 @@ applyUpgrades v cid height mc <- use txCache pure $ Just $ filterModuleCacheByKey (== "coin") mc - applyUpgrade :: PactUpgrade Pact4 -> TransactionM logger p (Maybe ModuleCache) - applyUpgrade upg = do + applyUpgrade :: [Transaction] -> Bool -> TransactionM logger p (Maybe ModuleCache) + applyUpgrade upg isPrecocious = do infoLog "Applying upgrade!" - let payloads = map (fmap payloadObj) $ _pact4UpgradeTransactions upg + let payloads = map (fmap payloadObj) upg -- -- In order to prime the module cache with all new modules for subsequent @@ -831,7 +833,7 @@ applyUpgrades v cid height -- init cache in the pact service state (_psInitCache). -- - let flags = flagsFor v cid (if _legacyUpgradeIsPrecocious upg then height + 1 else height) + let flags = flagsFor v cid (if isPrecocious then height + 1 else height) caches <- local (txExecutionConfig .~ ExecutionConfig flags) (mapM applyTx payloads) diff --git a/src/Chainweb/Pact5/TransactionExec.hs b/src/Chainweb/Pact5/TransactionExec.hs index 2f4311eb4..c0e4b5dbd 100644 --- a/src/Chainweb/Pact5/TransactionExec.hs +++ b/src/Chainweb/Pact5/TransactionExec.hs @@ -509,16 +509,18 @@ applyUpgrades -> TxContext -> IO () applyUpgrades logger db txCtx - | Just (ForPact5 upg) <- _chainwebVersion txCtx - ^? versionUpgrades - . atChain (_chainId txCtx) - . ix (ctxCurrentBlockHeight txCtx) - = applyUpgrade upg + | Just Pact4Upgrade{} <- + v ^? versionUpgrades . atChain cid . ix currentHeight = error "Expected Pact 4 upgrade, got Pact 5" + | Just Pact5Upgrade{_pact5UpgradeTransactions = upgradeTxs} <- + v ^? versionUpgrades . atChain cid . ix currentHeight = applyUpgrade upgradeTxs | otherwise = return () where - applyUpgrade :: PactUpgrade Pact5 -> IO () - applyUpgrade upg = do - forM_ (_pact5UpgradeTransactions upg) $ \tx -> + v = _chainwebVersion txCtx + currentHeight = ctxCurrentBlockHeight txCtx + cid = _chainId txCtx + applyUpgrade :: [Transaction] -> IO () + applyUpgrade upgradeTxs = do + forM_ upgradeTxs $ \tx -> tryAllSynchronous (runUpgrade logger db txCtx (view payloadObj <$> tx)) >>= \case Right _ -> pure () Left e -> do diff --git a/src/Chainweb/Rosetta/Internal.hs b/src/Chainweb/Rosetta/Internal.hs index 8bec2a49e..68658a2a6 100644 --- a/src/Chainweb/Rosetta/Internal.hs +++ b/src/Chainweb/Rosetta/Internal.hs @@ -129,7 +129,9 @@ matchLogs -> ExceptT RosettaFailure Handler tx matchLogs typ bh logs coinbase txs | bheight == genesisHeight v cid = matchGenesis - | Just (ForPact4 upg) <- v ^? versionUpgrades . atChain cid . at bheight . _Just = matchRemediation upg + | Just Pact4Upgrade{_pact4UpgradeTransactions = upgradeTxs} + <- v ^? versionUpgrades . atChain cid . at bheight . _Just + = matchRemediation upgradeTxs -- TODO: integrate pact 5? | otherwise = matchRest where @@ -141,15 +143,15 @@ matchLogs typ bh logs coinbase txs FullLogs -> genesisTransactions logs cid txs SingleLog rk -> genesisTransaction logs cid txs rk - matchRemediation upg = do + matchRemediation upgradeTxs = do hoistEither $ case typ of FullLogs -> overwriteError RosettaMismatchTxLogs $! - remediations logs cid coinbase (_pact4UpgradeTransactions upg) txs + remediations logs cid coinbase upgradeTxs txs SingleLog rk -> (noteOptional RosettaTxIdNotFound . overwriteError RosettaMismatchTxLogs) $ - singleRemediation logs cid coinbase (_pact4UpgradeTransactions upg) txs rk + singleRemediation logs cid coinbase upgradeTxs txs rk matchRest = hoistEither $ case typ of FullLogs -> diff --git a/src/Chainweb/Version.hs b/src/Chainweb/Version.hs index a4d4a6d29..5bff5af74 100644 --- a/src/Chainweb/Version.hs +++ b/src/Chainweb/Version.hs @@ -378,7 +378,7 @@ instance (NFData (f Pact4), NFData (f Pact5)) => NFData (ForBothPactVersions f) -- The type of upgrades, which are sets of transactions to run at certain block -- heights during coinbase. -data PactUpgrade (v :: PactVersion) where +data PactUpgrade where Pact4Upgrade :: { _pact4UpgradeTransactions :: [Pact4.Transaction] , _legacyUpgradeIsPrecocious :: Bool @@ -386,26 +386,27 @@ data PactUpgrade (v :: PactVersion) where -- forks of the next block, rather than the block the upgrade -- transactions are included in. do not use this for new upgrades -- unless you are sure you need it, this mostly exists for old upgrades. - } -> PactUpgrade Pact4 + } -> PactUpgrade Pact5Upgrade :: { _pact5UpgradeTransactions :: [Pact5.Transaction] - } -> PactUpgrade Pact5 + } -> PactUpgrade -instance Eq (PactUpgrade pv) where +instance Eq PactUpgrade where Pact4Upgrade txs precocious == Pact4Upgrade txs' precocious' = txs == txs' && precocious == precocious' Pact5Upgrade txs == Pact5Upgrade txs' = txs == txs' + _ == _ = False -instance Show (PactUpgrade pv) where +instance Show PactUpgrade where show Pact4Upgrade {} = "" show Pact5Upgrade {} = "" -instance NFData (PactUpgrade pv) where +instance NFData PactUpgrade where rnf (Pact4Upgrade txs precocious) = rnf txs `seq` rnf precocious rnf (Pact5Upgrade txs) = rnf txs -pact4Upgrade :: [Pact4.Transaction] -> PactUpgrade Pact4 +pact4Upgrade :: [Pact4.Transaction] -> PactUpgrade pact4Upgrade txs = Pact4Upgrade txs False -- The type of quirks, i.e. special validation behaviors that are in some @@ -449,7 +450,7 @@ data ChainwebVersion -- ^ The block heights on each chain to apply behavioral changes. -- Interpretation of these is up to the functions in -- `Chainweb.Version.Guards`. - , _versionUpgrades :: ChainMap (HashMap BlockHeight (ForSomePactVersion PactUpgrade)) + , _versionUpgrades :: ChainMap (HashMap BlockHeight PactUpgrade) -- ^ The Pact upgrade transactions to execute on each chain at certain block -- heights. , _versionBlockDelay :: BlockDelay @@ -746,4 +747,3 @@ onAllChains v f = OnChains <$> HM.traverseWithKey (\cid () -> f cid) (HS.toMap (chainIds v)) - diff --git a/src/Chainweb/Version/Mainnet.hs b/src/Chainweb/Version/Mainnet.hs index 974537761..ebee58537 100644 --- a/src/Chainweb/Version/Mainnet.hs +++ b/src/Chainweb/Version/Mainnet.hs @@ -189,23 +189,23 @@ mainnet = ChainwebVersion , _versionUpgrades = chainZip HM.union (indexByForkHeights mainnet [ (CoinV2, onChains - [ (unsafeChainId 0, ForPact4 $ pact4Upgrade MN0.transactions) - , (unsafeChainId 1, ForPact4 $ pact4Upgrade MN1.transactions) - , (unsafeChainId 2, ForPact4 $ pact4Upgrade MN2.transactions) - , (unsafeChainId 3, ForPact4 $ pact4Upgrade MN3.transactions) - , (unsafeChainId 4, ForPact4 $ pact4Upgrade MN4.transactions) - , (unsafeChainId 5, ForPact4 $ pact4Upgrade MN5.transactions) - , (unsafeChainId 6, ForPact4 $ pact4Upgrade MN6.transactions) - , (unsafeChainId 7, ForPact4 $ pact4Upgrade MN7.transactions) - , (unsafeChainId 8, ForPact4 $ pact4Upgrade MN8.transactions) - , (unsafeChainId 9, ForPact4 $ pact4Upgrade MN9.transactions) + [ (unsafeChainId 0, pact4Upgrade MN0.transactions) + , (unsafeChainId 1, pact4Upgrade MN1.transactions) + , (unsafeChainId 2, pact4Upgrade MN2.transactions) + , (unsafeChainId 3, pact4Upgrade MN3.transactions) + , (unsafeChainId 4, pact4Upgrade MN4.transactions) + , (unsafeChainId 5, pact4Upgrade MN5.transactions) + , (unsafeChainId 6, pact4Upgrade MN6.transactions) + , (unsafeChainId 7, pact4Upgrade MN7.transactions) + , (unsafeChainId 8, pact4Upgrade MN8.transactions) + , (unsafeChainId 9, pact4Upgrade MN9.transactions) ]) - , (Pact4Coin3, AllChains $ ForPact4 $ Pact4Upgrade CoinV3.transactions True) - , (Chainweb214Pact, AllChains $ ForPact4 $ Pact4Upgrade CoinV4.transactions True) - , (Chainweb215Pact, AllChains $ ForPact4 $ Pact4Upgrade CoinV5.transactions True) - , (Chainweb223Pact, AllChains $ ForPact4 $ pact4Upgrade CoinV6.transactions) + , (Pact4Coin3, AllChains $ Pact4Upgrade CoinV3.transactions True) + , (Chainweb214Pact, AllChains $ Pact4Upgrade CoinV4.transactions True) + , (Chainweb215Pact, AllChains $ Pact4Upgrade CoinV5.transactions True) + , (Chainweb223Pact, AllChains $ pact4Upgrade CoinV6.transactions) ]) - (onChains [(unsafeChainId 0, HM.singleton to20ChainsMainnet (ForPact4 $ pact4Upgrade MNKAD.transactions))]) + (onChains [(unsafeChainId 0, HM.singleton to20ChainsMainnet (pact4Upgrade MNKAD.transactions))]) , _versionCheats = VersionCheats { _disablePow = False , _fakeFirstEpochStart = False diff --git a/src/Chainweb/Version/RecapDevelopment.hs b/src/Chainweb/Version/RecapDevelopment.hs index 2680d9c1d..19e0576a3 100644 --- a/src/Chainweb/Version/RecapDevelopment.hs +++ b/src/Chainweb/Version/RecapDevelopment.hs @@ -80,12 +80,12 @@ recapDevnet = ChainwebVersion , _versionUpgrades = foldr (chainZip HM.union) (AllChains mempty) [ indexByForkHeights recapDevnet - [ (CoinV2, onChains [(unsafeChainId i, ForSomePactVersion Pact4T $ pact4Upgrade RecapDevnet.transactions) | i <- [0..9]]) - , (Pact4Coin3, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV5.transactions True)) + [ (CoinV2, onChains [(unsafeChainId i, pact4Upgrade RecapDevnet.transactions) | i <- [0..9]]) + , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) ] - , onChains [(unsafeChainId 0, HM.singleton to20ChainsHeight (ForSomePactVersion Pact4T $ pact4Upgrade MNKAD.transactions))] + , onChains [(unsafeChainId 0, HM.singleton to20ChainsHeight (pact4Upgrade MNKAD.transactions))] ] , _versionGraphs = diff --git a/src/Chainweb/Version/Registry.hs b/src/Chainweb/Version/Registry.hs index bfa9cc8fb..2f11d5ea6 100644 --- a/src/Chainweb/Version/Registry.hs +++ b/src/Chainweb/Version/Registry.hs @@ -111,9 +111,9 @@ validateVersion v = do where -- TODO: this is an annoying type sig, can we use NoMonoLocalBinds and disable the warning -- about matching on GADTs? - isUpgradeEmpty :: ForSomePactVersion PactUpgrade -> Bool - isUpgradeEmpty (ForSomePactVersion Pact4T upg) = null (_pact4UpgradeTransactions upg) - isUpgradeEmpty (ForSomePactVersion Pact5T upg) = null (_pact5UpgradeTransactions upg) + isUpgradeEmpty :: PactUpgrade -> Bool + isUpgradeEmpty Pact4Upgrade{_pact4UpgradeTransactions = upg} = null upg + isUpgradeEmpty Pact5Upgrade{_pact5UpgradeTransactions = upg} = null upg -- | Look up a version in the registry by code. lookupVersionByCode :: HasCallStack => ChainwebVersionCode -> ChainwebVersion diff --git a/src/Chainweb/Version/Testnet04.hs b/src/Chainweb/Version/Testnet04.hs index 89cae84e5..516644893 100644 --- a/src/Chainweb/Version/Testnet04.hs +++ b/src/Chainweb/Version/Testnet04.hs @@ -151,31 +151,30 @@ testnet04 = ChainwebVersion ] , _genesisTime = AllChains $ BlockCreationTime [timeMicrosQQ| 2019-07-17T18:28:37.613832 |] , _genesisBlockPayload = OnChains $ HM.fromList $ concat - [ [ (unsafeChainId 0, PN0.payloadBlock) - ] + [ [(unsafeChainId 0, PN0.payloadBlock)] , [(unsafeChainId i, PNN.payloadBlock) | i <- [1..19]] ] } , _versionUpgrades = chainZip HM.union (indexByForkHeights testnet04 [ (CoinV2, onChains $ - [ (unsafeChainId 0, ForSomePactVersion Pact4T $ pact4Upgrade MN0.transactions) - , (unsafeChainId 1, ForSomePactVersion Pact4T $ pact4Upgrade MN1.transactions) - , (unsafeChainId 2, ForSomePactVersion Pact4T $ pact4Upgrade MN2.transactions) - , (unsafeChainId 3, ForSomePactVersion Pact4T $ pact4Upgrade MN3.transactions) - , (unsafeChainId 4, ForSomePactVersion Pact4T $ pact4Upgrade MN4.transactions) - , (unsafeChainId 5, ForSomePactVersion Pact4T $ pact4Upgrade MN5.transactions) - , (unsafeChainId 6, ForSomePactVersion Pact4T $ pact4Upgrade MN6.transactions) - , (unsafeChainId 7, ForSomePactVersion Pact4T $ pact4Upgrade MN7.transactions) - , (unsafeChainId 8, ForSomePactVersion Pact4T $ pact4Upgrade MN8.transactions) - , (unsafeChainId 9, ForSomePactVersion Pact4T $ pact4Upgrade MN9.transactions) + [ (unsafeChainId 0, pact4Upgrade MN0.transactions) + , (unsafeChainId 1, pact4Upgrade MN1.transactions) + , (unsafeChainId 2, pact4Upgrade MN2.transactions) + , (unsafeChainId 3, pact4Upgrade MN3.transactions) + , (unsafeChainId 4, pact4Upgrade MN4.transactions) + , (unsafeChainId 5, pact4Upgrade MN5.transactions) + , (unsafeChainId 6, pact4Upgrade MN6.transactions) + , (unsafeChainId 7, pact4Upgrade MN7.transactions) + , (unsafeChainId 8, pact4Upgrade MN8.transactions) + , (unsafeChainId 9, pact4Upgrade MN9.transactions) ]) - , (Pact4Coin3, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV5.transactions True)) - , (Chainweb223Pact, AllChains $ ForSomePactVersion Pact4T $ pact4Upgrade CoinV6.transactions) + , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) + , (Chainweb223Pact, AllChains (pact4Upgrade CoinV6.transactions)) ]) - (onChains [(unsafeChainId 0, HM.singleton to20ChainsTestnet (ForSomePactVersion Pact4T $ pact4Upgrade MNKAD.transactions))]) + (onChains [(unsafeChainId 0, HM.singleton to20ChainsTestnet (pact4Upgrade MNKAD.transactions))]) , _versionCheats = VersionCheats { _disablePow = False , _fakeFirstEpochStart = False diff --git a/test/lib/Chainweb/Test/TestVersions.hs b/test/lib/Chainweb/Test/TestVersions.hs index 2f3872a5e..6147754c9 100644 --- a/test/lib/Chainweb/Test/TestVersions.hs +++ b/test/lib/Chainweb/Test/TestVersions.hs @@ -259,13 +259,13 @@ cpmTestVersion g v = v } & versionUpgrades .~ chainZip HM.union (indexByForkHeights v - [ (CoinV2, AllChains (ForSomePactVersion Pact4T $ pact4Upgrade Other.transactions)) - , (Pact4Coin3, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (ForSomePactVersion Pact4T $ Pact4Upgrade CoinV5.transactions True)) - , (Chainweb223Pact, AllChains (ForSomePactVersion Pact4T $ pact4Upgrade CoinV6.transactions)) + [ (CoinV2, AllChains (pact4Upgrade Other.transactions)) + , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) + , (Chainweb223Pact, AllChains (pact4Upgrade CoinV6.transactions)) ]) - (onChains [(unsafeChainId 3, HM.singleton (BlockHeight 2) (ForSomePactVersion Pact4T $ Pact4Upgrade MNKAD.transactions False))]) + (onChains [(unsafeChainId 3, HM.singleton (BlockHeight 2) (Pact4Upgrade MNKAD.transactions False))]) slowForks :: HashMap Fork (ChainMap ForkHeight) slowForks = tabulateHashMap \case @@ -448,7 +448,7 @@ pact5SlowCpmTestVersion g = buildTestVersion $ \v -> v , _genesisTime = AllChains $ BlockCreationTime epoch } & versionUpgrades .~ indexByForkHeights v - [ (Pact5Fork, AllChains (ForPact5 $ Pact5Upgrade (List.map pactTxFrom4To5 CoinV6.transactions))) + [ (Pact5Fork, AllChains (Pact5Upgrade (List.map pactTxFrom4To5 CoinV6.transactions))) ] & versionVerifierPluginNames .~ AllChains (Bottom From bf4dfa59f84e0265881e624d681756db224aca2f Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Thu, 12 Dec 2024 16:35:13 -0500 Subject: [PATCH 12/16] Document Chainweb.Block --- src/Chainweb/Block.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Chainweb/Block.hs b/src/Chainweb/Block.hs index 56aefc755..2d1e1be8f 100644 --- a/src/Chainweb/Block.hs +++ b/src/Chainweb/Block.hs @@ -1,3 +1,5 @@ +-- | A type for "blocks" including their header and payload and outputs. +-- This is only for REST APIs; we do not use the outputs otherwise. module Chainweb.Block (Block(..)) where From 63a2577295d351979110629b934e57c11b755e9a Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 10:31:32 -0500 Subject: [PATCH 13/16] Remove chronos source-dependency --- cabal.project | 6 ------ 1 file changed, 6 deletions(-) diff --git a/cabal.project b/cabal.project index faae0139f..95fa0bf7c 100644 --- a/cabal.project +++ b/cabal.project @@ -162,12 +162,6 @@ source-repository-package tag: 2f67d546ea6608fc6ebe5f2f6976503cbf340442 --sha256: 0x137akvbh4kr3qagksw74xdj2xz5vjnx1fbr41bb54a0lkcb8mm -source-repository-package - type: git - location: https://github.com/andrewthad/chronos - tag: b199bf6df1453af95832c2d2f9f0ef48c3622caa - --sha256: 056awkmdmkqdd5g3m8a1ibg2vp02kbppmidkfh4aildb1brq970a - source-repository-package type: git location: https://gitlab.com/edmundnoble/predicate-transformers From 40513b8eae7e302f01081d3ca79b44813ea8ee82 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 10:31:32 -0500 Subject: [PATCH 14/16] Remove duplicate module listing in cabal file --- chainweb.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/chainweb.cabal b/chainweb.cabal index f0a1d4143..3516de894 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -628,7 +628,6 @@ test-suite chainweb-tests Chainweb.Test.BlockHeaderDB Chainweb.Test.BlockHeaderDB.PruneForks Chainweb.Test.Chainweb.Utils.Paging - Chainweb.Test.Chainweb.Utils.Paging Chainweb.Test.CutDB Chainweb.Test.Difficulty Chainweb.Test.Mempool From 26a208e20cfb25dddaf73a2c5a29b3c653e744de Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 10:31:32 -0500 Subject: [PATCH 15/16] delete comment --- src/Chainweb/Chainweb.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Chainweb/Chainweb.hs b/src/Chainweb/Chainweb.hs index 998305363..0dc8cdc7e 100644 --- a/src/Chainweb/Chainweb.hs +++ b/src/Chainweb/Chainweb.hs @@ -72,8 +72,6 @@ module Chainweb.Chainweb , NowServing(..) -- ** Mempool integration --- , Pact4.Transaction --- , Pact5.Transaction , Mempool.pact4TransactionConfig , validatingMempoolConfig From 0f5ec0964b1a0ebc2e3a56dc03718591bad04cb1 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 13:20:57 -0500 Subject: [PATCH 16/16] Pact5.ChainwebPactDb comments and tx diagram --- src/Chainweb/Pact5/Backend/ChainwebPactDb.hs | 57 +++++++++++++++++--- 1 file changed, 50 insertions(+), 7 deletions(-) diff --git a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs index 59c7389cf..b186e9b9d 100644 --- a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs @@ -18,6 +18,45 @@ -- TODO pact5: fix the orphan PactDbFor instance {-# OPTIONS_GHC -Wno-orphans #-} +-- | The database operations that manipulate and read the Pact state. + +-- Note: [Pact Transactions] + +-- What is a "pact transaction"? There are three levels of transactions going on: +-- +-------------------------------------------------------------------------------------------------------------------------+ +-- | Block | +-- | | +-- | +-----------------+ +---------------------------------------------+ +-----------------------------------------------+ | +-- | | Apply Coinbase | | Apply Command | | Apply Command | | +-- | | | | |+------------+ +------------+ +------------+ | |+------------+ +------------+ +------------+ | | +-- | | | | || Buy | | Run | | Redeem | | || Buy | | Run | | Redeem | | | +-- | | v | || Gas | | Payload | | Gas | | || Gas | | Payload | | Gas | | | +-- | | Pact tx | || | | | | | | | | | || | | | | | | | | | | +-- | | (begin-tx) | || v | | v | | v | +-->|| v | | v | | v | | | +-- | +v----------------+ || Pact tx | | Pact tx | | Pact tx | | || Pact tx | | Pact tx | | Pact tx | | | +-- | Pact5Db tx || (begin-tx) | | (begin-tx) | | (begin-tx) | | || (begin-tx) | | (begin-tx) | | (begin-tx) | | | +-- | || | | | | | | || | | | | | | | +-- | |+------------+ +------------+ +------------+ | |+------------+ +------------+ +------------+ | | +-- | | | | | | +-- | +v--------------------------------------------+ +v----------------------------------------------+ | +-- | Pact5Db tx Pact5Db tx | +-- +v------------------------------------------------------------------------------------------------------------------------+ +-- SQLite tx (withSavepoint) +-- (in some cases multiple blocks in tx) +-- +-- +-- Transactions must be nested in this way. +-- +-- SQLite transaction ensures that the Pact5Db transaction +-- sees a consistent view of the database, especially if its +-- writes are committed later. +-- +-- Pact5Db tx ensures that the Pact tx's writes +-- are recorded. +-- +-- Pact tx ensures that failed transactions' writes are not recorded. + + module Chainweb.Pact5.Backend.ChainwebPactDb ( chainwebPactBlockDb , Pact5Db(..) @@ -133,14 +172,15 @@ data Pact5Db = Pact5Db -> Maybe RequestKey -> (Pact.PactDb Pact.CoreBuiltin Pact.Info -> IO a) -> IO (a, BlockHandle) - -- ^ Give this function a BlockHandle representing the state of a block so far, - -- and it will allow you to access a PactDb which contains the Pact state - -- as of that point in the block. After you're done, it passes you back - -- a BlockHandle representing the state of the block extended with any - -- writes you made to the PactDb. Note also that this function handles - -- registering transactions as completed, if you pass it a RequestKey. + -- ^ Give this function a BlockHandle representing the state of a pending + -- block and it will pass you a PactDb which contains the Pact state as of + -- that point in the block. After you're done, it passes you back a + -- BlockHandle representing the state of the block extended with any writes + -- you made to the PactDb. + -- Note also that this function handles registering + -- transactions as completed, if you pass it a RequestKey. , lookupPactTransactions :: Vector RequestKey -> IO (HashMap RequestKey (T2 BlockHeight BlockHash)) - -- ^ Used to implement transaction polling. + -- ^ Used to implement transaction polling. } type instance PactDbFor logger Pact5 = Pact5Db @@ -259,6 +299,9 @@ chainwebPactBlockDb maybeLimit env = Pact5Db Nothing -> basePactDb r <- kont maybeLimitedPactDb finalState <- readMVar stateVar + -- TODO: this may not be wanted when we allow more unconstrained access + -- to the Pact state - which we may do in the future, to run Pact REPL files + -- with chainweb's Pact state. Perhaps we use ExecutionMode to flag this? when (isJust (_bsPendingTx finalState)) $ internalDbError "dangling transaction" -- Register a successful transaction in the pending data for the block