diff --git a/README.md b/README.md index 0e36cab7d1..7638493fb6 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: diff --git a/cabal.project b/cabal.project index 94703e8704..95fa0bf7cd 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 @@ -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 diff --git a/chainweb.cabal b/chainweb.cabal index f0a1d41434..3516de894a 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 diff --git a/src/Chainweb/Block.hs b/src/Chainweb/Block.hs index 56aefc7557..2d1e1be8f9 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 diff --git a/src/Chainweb/BlockHeader.hs b/src/Chainweb/BlockHeader.hs index 25a916de82..c844e834fd 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 1643f2aa09..b3d75ca56d 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) diff --git a/src/Chainweb/Chainweb.hs b/src/Chainweb/Chainweb.hs index 9983053632..0dc8cdc7ef 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 diff --git a/src/Chainweb/Mempool/InMem.hs b/src/Chainweb/Mempool/InMem.hs index 86308f0ccd..9f2f7f62f9 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 diff --git a/src/Chainweb/Pact/Backend/Compaction.hs b/src/Chainweb/Pact/Backend/Compaction.hs index 02cf34fde6..eae063fdbd 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 () diff --git a/src/Chainweb/Pact/Backend/Utils.hs b/src/Chainweb/Pact/Backend/Utils.hs index ffdafc4506..ccbdf7715c 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.hs b/src/Chainweb/Pact/PactService.hs index 09bed4c754..4e6c50393c 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 @@ -495,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 @@ -565,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 @@ -1129,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 diff --git a/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs b/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs index d043cef759..b9f1a14af9 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/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 670b2856bb..5a1cb92d05 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 64ec19d8ce..b3bacc5077 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) diff --git a/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs index 5c1e137165..3e34ed978e 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/Pact4/TransactionExec.hs b/src/Chainweb/Pact4/TransactionExec.hs index a6b1f01b99..d052dbd423 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/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs index c6bdc7ac95..b186e9b9d4 100644 --- a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs @@ -18,16 +18,55 @@ -- 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 - ( chainwebPactCoreBlockDb + ( chainwebPactBlockDb , Pact5Db(..) , BlockHandlerEnv(..) , blockHandlerDb , blockHandlerLogger , toTxLog , toPactTxLog - , getEndTxId - , getEndTxId' + , domainTableName + , convRowKey ) where import Data.Coerce @@ -55,8 +94,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 +105,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 +127,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 +144,7 @@ data BlockHandlerEnv logger = BlockHandlerEnv , _blockHandlerVersion :: !ChainwebVersion , _blockHandlerBlockHeight :: !BlockHeight , _blockHandlerChainId :: !ChainId - , _blockHandlerMode :: !ExecutionMode + , _blockHandlerMode :: !Pact.ExecutionMode , _blockHandlerPersistIntraBlockWrites :: !IntraBlockPersistence } @@ -121,16 +152,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,16 +170,17 @@ 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 - -- 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 @@ -158,7 +190,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 +213,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,50 +252,56 @@ 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 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 @@ -264,7 +333,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 +348,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 +386,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 +398,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 +410,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 +425,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 +485,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 +569,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 +605,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 +619,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 +650,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 +665,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 +697,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 +728,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 diff --git a/src/Chainweb/Pact5/TransactionExec.hs b/src/Chainweb/Pact5/TransactionExec.hs index 2f4311eb45..c0e4b5dbd5 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 8bec2a49e5..68658a2a6e 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 a4d4a6d292..5bff5af741 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 974537761b..ebee58537d 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 2680d9c1db..19e0576a36 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 bfa9cc8fb7..2f11d5ea66 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 89cae84e5e..5166448935 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 2f3872a5e9..6147754c96 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