diff --git a/chainweb.cabal b/chainweb.cabal index 57eac648ad..2d846860cf 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -234,11 +234,6 @@ library , Chainweb.RestAPI.NodeInfo , Chainweb.RestAPI.Orphans , Chainweb.RestAPI.Utils - , Chainweb.Rosetta.Internal - , Chainweb.Rosetta.RestAPI - , Chainweb.Rosetta.RestAPI.Client - , Chainweb.Rosetta.RestAPI.Server - , Chainweb.Rosetta.Utils , Chainweb.SPV , Chainweb.SPV.CreateProof , Chainweb.SPV.EventProof @@ -440,7 +435,6 @@ library , primitive >= 0.7.1.0 , random >= 1.2 , rocksdb-haskell-kadena >= 1.1.0 - , rosetta >= 1.0 , safe-exceptions >= 0.1 , scheduler >= 1.4 , semigroupoids >= 5.3.7 @@ -568,7 +562,6 @@ library chainweb-test-utils , resourcet >= 1.3 , retry >= 0.7 , rocksdb-haskell-kadena >= 1.1.0 - , rosetta >= 1.0 , safe-exceptions >= 0.1 , servant >= 0.20.1 , servant-client >= 0.18.2 @@ -660,8 +653,6 @@ test-suite chainweb-tests Chainweb.Test.Pact5.SPVTest Chainweb.Test.Pact5.TransactionExecTest Chainweb.Test.RestAPI - Chainweb.Test.Rosetta - Chainweb.Test.Rosetta.RestAPI Chainweb.Test.Roundtrips Chainweb.Test.SPV Chainweb.Test.SPV.EventProof @@ -731,7 +722,6 @@ test-suite chainweb-tests , random >= 1.2 , resource-pool >= 0.4 , resourcet >= 1.3 - , rosetta >= 1.0 , safe-exceptions >= 0.1 , scheduler >= 1.4 , servant-client >= 0.18.2 diff --git a/rosetta/README.md b/rosetta/README.md index 2c887d8217..4b50667db8 100644 --- a/rosetta/README.md +++ b/rosetta/README.md @@ -1,42 +1,3 @@ # Rosetta Kadena -## Testing with rosetta-cli -To validate Kadena's rosetta implementation, install [rosetta-cli](https://github.com/coinbase/rosetta-cli#install) and run one of the following commands: - -1. This command validates that the Data API information in the testnet network is correct. It also ensures that the implementation does not miss any balance-changing operations. -``` -rosetta-cli check:data --configuration-file rosetta-cli-conf/testnet/chain0/configTestnetChain0.json -``` - -2. This command validates the blockchain’s construction, signing, and broadcasting. -See `rosetta-cli-conf/testnet/chain0/testnet-chain00.ros` for an example of the types of operations supported. -_Only k:accounts transfers are currently available._ -``` -rosetta-cli check:construction --configuration-file rosetta-cli-conf/testnet/chain0/configTestnetChain0.json -``` - -3. This command validates that the Data API information in the mainnet network is correct. It also ensures that the implementation does not miss any balance-changing operations. -``` -rosetta-cli check:data --configuration-file rosetta-cli-conf/mainnet/chain0/configMainnetChain0.json -``` - - -A couple of things to note: -- The configuration files included here assume testing on chain “0”. -- To run these `rosetta-cli` commands on another chain (valid chains are chains “0” through “19”), change sub_network_identifier.network from “0” to the chain id of your choice. Chain id is expected as a string not a number. -- Replace `localhost` in the `online_url` and `offline_url` fields with the IP address of the testing node that has rosetta enabled for the network (e.g. testnet or mainnet) you’re testing. -- `testnet04` refers to tesnet, and `mainnet01` refers to mainnet. - -## Funding Accounts -As part of the testing workflow of the Construction API, accounts need to be funded. - -The testnet faucet for chain 1 can be found here: https://faucet.testnet.chainweb.com/ - -In order to fund accounts using these pre funded accounts, we suggest using https://github.com/kadena-io/kda-exchange-integration and to follow the withdrawal example. - -Some clarifications on this example: -``` -processWithdraw('coin', EXCHANGE_KACCOUNT, EXCHANGE_PRIVKEY, customerAddress, 10, "13").then((res) => console.log(res)) -``` -- `10` refers to the amount to be transferred -- `“13”` refers to the chain id where the “customerAddress” is located +chainweb-node no longer provides an implementation of the rosetta API. diff --git a/rosetta/mainnet/chain0/configMainnetChain0.json b/rosetta/mainnet/chain0/configMainnetChain0.json deleted file mode 100644 index 7f15525b04..0000000000 --- a/rosetta/mainnet/chain0/configMainnetChain0.json +++ /dev/null @@ -1,52 +0,0 @@ -{ - "network": { - "blockchain": "kadena", - "network": "mainnet01", - "sub_network_identifier": { - "network": "0" - } - }, - "online_url": "http://localhost:1848/chainweb/0.0/mainnet01/rosetta", - "data_directory": "logs/chain0", - "http_timeout": 10, - "max_retries": 5, - "retry_elapsed_time": 0, - "max_online_connections": 120, - "max_sync_concurrency": 64, - "tip_delay": 300, - "max_reorg_depth": 100, - "log_configuration": false, - "compression_disabled": false, - "memory_limit_disabled": false, - "error_stack_trace_enabled": false, - "construction": null, - "data": { - "active_reconciliation_concurrency": 16, - "inactive_reconciliation_concurrency": 4, - "inactive_reconciliation_frequency": 250, - "log_blocks": true, - "log_transactions": false, - "log_balance_changes": false, - "log_reconciliations": false, - "ignore_reconciliation_error": false, - "exempt_accounts": "", - "bootstrap_balances": "", - "interesting_accounts": "", - "reconciliation_disabled": false, - "reconciliation_drain_disabled": false, - "inactive_discrepancy_search_disabled": false, - "balance_tracking_disabled": false, - "coin_tracking_disabled": false, - "status_port": 9090, - "results_output_file": "", - "pruning_disabled": false, - "initial_balance_fetch_disabled": false, - "end_conditions": { - "reconciliation_coverage": { - "coverage": 0.95, - "from_tip": true, - "tip": true - } - } - } -} diff --git a/rosetta/testnet/chain0/configTestnetChain0.json b/rosetta/testnet/chain0/configTestnetChain0.json deleted file mode 100644 index db4266e239..0000000000 --- a/rosetta/testnet/chain0/configTestnetChain0.json +++ /dev/null @@ -1,59 +0,0 @@ -{ - "network": { - "blockchain": "kadena", - "network": "testnet04", - "sub_network_identifier": { - "network": "0" - } - }, - "online_url": "http://localhost:1848/chainweb/0.0/testnet04/rosetta", - "data_directory": "logs/testnet/chain0", - "http_timeout": 10, - "max_retries": 5, - "retry_elapsed_time": 0, - "max_online_connections": 120, - "max_sync_concurrency": 64, - "tip_delay": 300, - "max_reorg_depth": 100, - "log_configuration": false, - "compression_disabled": false, - "memory_limit_disabled": false, - "error_stack_trace_enabled": false, - "construction": { - "offline_url": "http://localhost:1848/chainweb/0.0/testnet04/rosetta", - "constructor_dsl_file": "testnet-chain00.ros", - "end_conditions": { - "create_account": 10, - "transfer": 20 - } - }, - "data": { - "active_reconciliation_concurrency": 16, - "inactive_reconciliation_concurrency": 4, - "inactive_reconciliation_frequency": 250, - "log_blocks": true, - "log_transactions": false, - "log_balance_changes": false, - "log_reconciliations": false, - "ignore_reconciliation_error": false, - "exempt_accounts": "", - "bootstrap_balances": "", - "interesting_accounts": "", - "reconciliation_disabled": false, - "reconciliation_drain_disabled": false, - "inactive_discrepancy_search_disabled": false, - "balance_tracking_disabled": false, - "coin_tracking_disabled": false, - "status_port": 9090, - "results_output_file": "", - "pruning_disabled": false, - "initial_balance_fetch_disabled": false, - "end_conditions": { - "reconciliation_coverage": { - "coverage": 0.95, - "from_tip": true, - "tip": true - } - } - } -} diff --git a/rosetta/testnet/chain0/testnet-chain00.ros b/rosetta/testnet/chain0/testnet-chain00.ros deleted file mode 100644 index 2bae08bdf8..0000000000 --- a/rosetta/testnet/chain0/testnet-chain00.ros +++ /dev/null @@ -1,321 +0,0 @@ -// Testing configuration for -// transfer and create-account operations. - -request_funds(1){ - find_account{ - print_message("finding account"); - currency = {"symbol":"KDA", "decimals":12}; - random_account = find_balance({ - "minimum_balance":{ - "value": "0", - "currency": {{currency}} - }, - "create_limit":1 - }); - }, - - // Create a separate scenario to request funds so that - // the address we are using to request funds does not - // get rolled back if funds do not yet exist. - request{ - loaded_account = find_balance({ - "account_identifier": {{random_account.account_identifier}}, - "minimum_balance":{ - "value": "1000000000000", // 1 KDA - "currency": {{currency}} - } - }); - } -} - - -create_account(1){ - create{ - network = { - "network":"testnet04", - "blockchain":"kadena", - "sub_network_identifier": { - "network": "0" - } - }; - key = generate_key({"curve_type":"edwards25519"}); - - // Returns the account name in the format: - // k: - account = derive({ - "network_identifier": {{network}}, - "public_key": {{key.public_key}} - }); - ownership = {{account.metadata.ownership}}; - - // Associates an account with its Pact ownership - // (a key set with a predicate of "keys-all"). - // Currently, we only support k: accounts, so - // this implementation assumes that this account - // is only owned by the public key used to derive - // the account name. - // This is used when constructing operations in transfer - // workflows. - set_blob({ - "key":{{account.account_identifier}}, - "value":{{account.metadata.ownership}} - }); - - save_account({ - "account_identifier": {{account.account_identifier}}, - "keypair": {{key}} - }); - } -} - -transfer(10){ - transfer_dry_run{ - transfer_dry_run.network = { - "network":"testnet04", - "blockchain":"kadena", - "sub_network_identifier": { - "network": "0" - } - }; - currency = {"symbol":"KDA", "decimals":12}; - sender = find_balance({ - "minimum_balance":{ - "value": "100000000000", // 0.1 KDA - "currency": {{currency}} - } - }); - - - // Set the recipient_amount as some value <= sender.balance-max_fee - max_fee = "6000000"; - raw_available_amount = {{sender.balance.value}} - {{max_fee}}; - raw_recipient_amount = random_number({"minimum": "1", "maximum": {{raw_available_amount}}}); - - // Find recipient and construct operations - raw_sender_amount = 0 - {{raw_recipient_amount}}; - recipient = find_balance({ - "not_account_identifier":[{{sender.account_identifier}}], - "minimum_balance":{ - "value": "0", - "currency": {{currency}} - }, - "create_limit": 100, - "create_probability": 50 - }); - transfer_dry_run.confirmation_depth = "1"; - transfer_dry_run.dry_run = true; - - senderOwnership = get_blob({ - "key":{{sender.account_identifier}} - }); - recipientOwnership = get_blob({ - "key":{{recipient.account_identifier}} - }); - - // This operation's metadata indicates - // if an account's ownership changed - // during this operation. - // Even though Kadena supports keyset - // rotation, this implementation - // assumes no rotation occurred. - senderOperationMetadata = { - "prev-ownership": {{senderOwnership}}, - "curr-ownership": {{senderOwnership}} - }; - recipientOperationMetadata = { - "prev-ownership": {{recipientOwnership}}, - "curr-ownership": {{recipientOwnership}} - }; - - transfer_dry_run.operations = [ - { - "operation_identifier":{"index":1}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{sender.account_identifier}}, - "amount":{ - "value":{{raw_sender_amount}}, - "currency":{{currency}} - }, - "metadata": {{senderOperationMetadata}} - }, - { - "operation_identifier":{"index":2}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{recipient.account_identifier}}, - "amount":{ - "value":{{raw_recipient_amount}}, - "currency":{{currency}} - }, - "metadata": {{recipientOperationMetadata}} - } - ]; - transfer_dry_run.preprocess_metadata = { "gas_payer": {{sender.account_identifier}} }; - }, - - transfer{ - // The suggested_fee is returned in the /construction/metadata - // response and saved to transfer_dry_run.suggested_fee. - suggested_fee = find_currency_amount({ - "currency":{{currency}}, - "amounts":{{transfer_dry_run.suggested_fee}} - }); - - available_amount = {{sender.balance.value}} - {{suggested_fee.value}}; - recipient_amount = random_number({"minimum": "1", "maximum": {{available_amount}}}); - sender_amount = 0 - {{recipient_amount}}; - - transfer.network = {{transfer_dry_run.network}}; - transfer.confirmation_depth = {{transfer_dry_run.confirmation_depth}}; - - transfer.operations = [ - { - "operation_identifier":{"index":1}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{sender.account_identifier}}, - "amount":{ - "value":{{sender_amount}}, - "currency":{{currency}} - }, - "metadata": {{senderOperationMetadata}} - }, - { - "operation_identifier":{"index":2}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{recipient.account_identifier}}, - "amount":{ - "value":{{recipient_amount}}, - "currency":{{currency}} - }, - "metadata": {{recipientOperationMetadata}} - } - ]; - transfer.preprocess_metadata = {{transfer_dry_run.preprocess_metadata}}; - } -} - -return_funds(10){ - transfer_dry_run{ - transfer_dry_run.network = { - "network":"testnet04", - "blockchain":"kadena", - "sub_network_identifier": { - "network": "0" - } - }; - currency = {"symbol":"KDA", "decimals":12}; - raw_max_fee = "6000000"; - raw_sender = find_balance({ - "minimum_balance":{ - "value": {{raw_max_fee}}, - "currency": {{currency}} - } - }); - - // Set the recipient_amount as some sender.balance-max_fee - raw_available_amount = {{raw_sender.balance.value}} - {{raw_max_fee}}; - print_message({"available_amount":{{raw_available_amount}}}); - raw_sender_amount = 0 - {{raw_available_amount}}; - - // Provide a static address as the recipient and construct operations - faucet = {"address":"k:9a51a7974d98ff6902db5edad14dc5e194df2dad29afe4efa0185132a667f6ad"}; - faucetOperationMetadata = { - "prev-ownership": { - "pred": "keys-all", - "keys": ["9a51a7974d98ff6902db5edad14dc5e194df2dad29afe4efa0185132a667f6ad"]}, - "curr-ownership": { - "pred": "keys-all", - "keys": ["9a51a7974d98ff6902db5edad14dc5e194df2dad29afe4efa0185132a667f6ad"]} - }; - - senderOwnership = get_blob({ - "key":{{raw_sender.account_identifier}} - }); - senderOperationMetadata = { - "prev-ownership": {{senderOwnership}}, - "curr-ownership": {{senderOwnership}} - }; - - transfer_dry_run.confirmation_depth = "1"; - transfer_dry_run.dry_run = true; - - transfer_dry_run.operations = [ - { - "operation_identifier":{"index":1}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{raw_sender.account_identifier}}, - "amount":{ - "value":{{raw_sender_amount}}, - "currency":{{currency}} - }, - "metadata": {{senderOperationMetadata}} - }, - { - "operation_identifier":{"index":2}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{faucet}}, - "amount":{ - "value":{{raw_available_amount}}, - "currency":{{currency}} - }, - "metadata": {{faucetOperationMetadata}} - } - ]; - transfer_dry_run.preprocess_metadata = { "gas_payer": {{raw_sender.account_identifier}} }; - }, - - transfer{ - - // The suggested_fee is returned in the /construction/metadata - // response and saved to transfer_dry_run.suggested_fee. - suggested_fee = find_currency_amount({ - "currency":{{currency}}, - "amounts":{{transfer_dry_run.suggested_fee}} - }); - - sender = find_balance({ - "minimum_balance":{ - "value": {{suggested_fee.value}}, - "currency": {{currency}} - } - }); - - // Set the recipient_amount as some sender.balance-max_fee - available_amount = {{sender.balance.value}} - {{suggested_fee.value}}; - sender_amount = 0 - {{available_amount}}; - - transfer.network = {{transfer_dry_run.network}}; - transfer.confirmation_depth = {{transfer_dry_run.confirmation_depth}}; - - transfer.operations = [ - { - "operation_identifier":{"index":1}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{sender.account_identifier}}, - "amount":{ - "value":{{sender_amount}}, - "currency":{{currency}} - }, - "metadata": {{senderOperationMetadata}} - }, - { - "operation_identifier":{"index":2}, - "status": "Successful", - "type":"TransferOrCreateAcct", - "account":{{faucet}}, - "amount":{ - "value":{{available_amount}}, - "currency":{{currency}} - }, - "metadata": {{faucetOperationMetadata}} - } - ]; - transfer.preprocess_metadata = { "gas_payer": {{sender.account_identifier}} }; - } -} diff --git a/src/Chainweb/Chainweb.hs b/src/Chainweb/Chainweb.hs index 0dc8cdc7ef..007d02fbb3 100644 --- a/src/Chainweb/Chainweb.hs +++ b/src/Chainweb/Chainweb.hs @@ -917,10 +917,6 @@ runChainweb cw nowServing = do pactDbsToServe (_chainwebCoordinator cw) (HeaderStream . _configHeaderStream $ _chainwebConfig cw) - (Rosetta - (_configRosetta $ _chainwebConfig cw) - (_configRosettaConstructionApi (_chainwebConfig cw)) - ) (_chainwebBackup cw <$ guard backupApiEnabled) (_serviceApiPayloadBatchLimit . _configServiceApi $ _chainwebConfig cw) mw diff --git a/src/Chainweb/Chainweb/Configuration.hs b/src/Chainweb/Chainweb/Configuration.hs index 90b2009f15..0d2d61bcd7 100644 --- a/src/Chainweb/Chainweb/Configuration.hs +++ b/src/Chainweb/Chainweb/Configuration.hs @@ -65,8 +65,6 @@ module Chainweb.Chainweb.Configuration , configMinGasPrice , configThrottling , configReorgLimit -, configRosetta -, configRosettaConstructionApi , configFullHistoricPactState , configBackup , configServiceApi @@ -399,8 +397,6 @@ data ChainwebConfiguration = ChainwebConfiguration , _configPreInsertCheckTimeout :: !Micros , _configAllowReadsInLocal :: !Bool , _configFullHistoricPactState :: !Bool - , _configRosetta :: !Bool - , _configRosettaConstructionApi :: !Bool , _configBackup :: !BackupConfig , _configServiceApi :: !ServiceApiConfig , _configReadOnlyReplay :: !Bool @@ -427,37 +423,8 @@ validateChainwebConfiguration c = do validateBackupConfig (_configBackup c) unless (c ^. chainwebVersion . versionDefaults . disablePeerValidation) $ validateP2pConfiguration (_configP2p c) - validateRosetta c validateChainwebVersion (_configChainwebVersion c) -validateRosetta :: ConfigValidation ChainwebConfiguration [] -validateRosetta c = do - when (_configRosetta c) $ - tell $ pure $ T.unwords - [ "Rosetta is deprecated and will be removed in upcoming versions of chainweb-node." - , "The use of Rosetta is strongly discouraged." - , "USE AT YOUR OWN RISK." - , "No guarantees are made regarding the correctness of any responses of the Rosetta API." - , "If your business depends on Rosetta, please submit request at https://github.com/kadena-io/chainweb-node/issues." - ] - when (_configRosetta c) $ - tell $ pure $ T.unwords - [ "Starting with chainweb-node version 2.25 the Rosetta construction API is not enabled automatically when Rosetta is enabled." - , "It can be enabled with the '--rosetta-construction-api' command line flag or via the 'rosettaConstructionApi' configuration setting." - ] - when (_configRosettaConstructionApi c) $ - tell $ pure $ T.unwords - [ "WARNING: the Rosetta construction API is not officially supported any more by chainweb-node." - , "NO GUARANTEE IS MADE ABOUT THE SOUNDNESS OF THIS API." - ] - when (_configRosetta c && not (_configFullHistoricPactState c)) $ - throwError $ T.unwords - [ "To enable Rosetta, full historic pact state must also be enabled or" - , "the Rosetta index will be incomplete." - ] - when (_configRosettaConstructionApi c && not (_configRosetta c)) $ - throwError "To enable the Rosetta construction API, Rosetta must be enabled, too." - validateChainwebVersion :: ConfigValidation ChainwebVersion [] validateChainwebVersion v = do unless (isDevelopment || elem v knownVersions) $ @@ -501,8 +468,6 @@ defaultChainwebConfiguration v = ChainwebConfiguration , _configReorgLimit = defaultReorgLimit , _configPreInsertCheckTimeout = defaultPreInsertCheckTimeout , _configAllowReadsInLocal = False - , _configRosetta = False - , _configRosettaConstructionApi = False , _configFullHistoricPactState = True , _configServiceApi = defaultServiceApiConfig , _configOnlySyncPact = False @@ -530,8 +495,6 @@ instance ToJSON ChainwebConfiguration where , "reorgLimit" .= _configReorgLimit o , "preInsertCheckTimeout" .= _configPreInsertCheckTimeout o , "allowReadsInLocal" .= _configAllowReadsInLocal o - , "rosetta" .= _configRosetta o - , "rosettaConstructionApi" .= _configRosettaConstructionApi o , "fullHistoricPactState" .= _configFullHistoricPactState o , "serviceApi" .= _configServiceApi o , "onlySyncPact" .= _configOnlySyncPact o @@ -563,8 +526,6 @@ instance FromJSON (ChainwebConfiguration -> ChainwebConfiguration) where <*< configReorgLimit ..: "reorgLimit" % o <*< configAllowReadsInLocal ..: "allowReadsInLocal" % o <*< configPreInsertCheckTimeout ..: "preInsertCheckTimeout" % o - <*< configRosetta ..: "rosetta" % o - <*< configRosettaConstructionApi ..: "rosettaConstructionApi" % o <*< configFullHistoricPactState ..: "fullHistoricPactState" % o <*< configServiceApi %.: "serviceApi" % o <*< configOnlySyncPact ..: "onlySyncPact" % o @@ -609,12 +570,6 @@ pChainwebConfiguration = id <*< configAllowReadsInLocal .:: boolOption_ % long "allowReadsInLocal" <> help "Enable direct database reads of smart contract tables in local queries." - <*< configRosetta .:: boolOption_ - % long "rosetta" - <> help "DEPRECATED: Enable the Rosetta endpoints." - <*< configRosettaConstructionApi .:: boolOption_ - % long "rosetta-construction-api" - <> help "DEPRECATED: Enable the Rosetta Construction API. DO NOT USE. No guarantees are provided about the correctness of this feature." <*< configFullHistoricPactState .:: boolOption_ % long "full-historic-pact-state" <> help "Write full historic Pact state; only enable for custodial or archival nodes." diff --git a/src/Chainweb/Pact/Backend/Types.hs b/src/Chainweb/Pact/Backend/Types.hs index 223baf6c7a..7366334751 100644 --- a/src/Chainweb/Pact/Backend/Types.hs +++ b/src/Chainweb/Pact/Backend/Types.hs @@ -49,8 +49,7 @@ import Data.List.NonEmpty (NonEmpty) import Control.DeepSeq (NFData) -- | Whether we write rows to the database that were already overwritten --- in the same block. This is temporarily necessary to do while Rosetta uses --- those rows to determine the contents of historic transactions. +-- in the same block. data IntraBlockPersistence = PersistIntraBlockWrites | DoNotPersistIntraBlockWrites deriving (Eq, Ord, Show) diff --git a/src/Chainweb/RestAPI.hs b/src/Chainweb/RestAPI.hs index 3a48a06eae..bb2aa56518 100644 --- a/src/Chainweb/RestAPI.hs +++ b/src/Chainweb/RestAPI.hs @@ -32,7 +32,6 @@ module Chainweb.RestAPI -- * Component Triggers , HeaderStream(..) -, Rosetta(..) -- * Chainweb P2P API Server , someChainwebServer @@ -62,7 +61,6 @@ module Chainweb.RestAPI import Control.Monad (guard) -import Data.Bifunctor import Data.Bool (bool) import GHC.Generics (Generic) @@ -104,7 +102,6 @@ import Chainweb.RestAPI.Health import Chainweb.RestAPI.NetworkID import Chainweb.RestAPI.NodeInfo import Chainweb.RestAPI.Utils -import Chainweb.Rosetta.RestAPI.Server import Chainweb.SPV.RestAPI.Server (someSpvServers) import Chainweb.Utils import Chainweb.Version @@ -169,11 +166,6 @@ emptyChainwebServerDbs = ChainwebServerDbs -- -------------------------------------------------------------------------- -- -- Component Triggers -data Rosetta = Rosetta - { _rosettaDefault :: {-# UNPACK #-} !Bool - , _rosettaConstructionApi :: {-# UNPACK #-} !Bool - } - newtype HeaderStream = HeaderStream Bool -- -------------------------------------------------------------------------- -- @@ -372,26 +364,15 @@ someServiceApiServer -> [(ChainId, PactAPI.PactServerData logger tbl)] -> Maybe (MiningCoordination logger tbl) -> HeaderStream - -> Rosetta -> Maybe (BackupEnv logger) -> PayloadBatchLimit -> SomeServer -someServiceApiServer v dbs pacts mr (HeaderStream hs) (Rosetta r rc) backupEnv pbl = +someServiceApiServer v dbs pacts mr (HeaderStream hs) backupEnv pbl = someHealthCheckServer <> maybe mempty (someBackupServer v) backupEnv <> maybe mempty (someNodeInfoServer v) cuts <> PactAPI.somePactServers v pacts <> maybe mempty (Mining.someMiningServer v) mr - <> maybe mempty (bool mempty (someRosettaServer v payloads concreteMs cutPeerDb concretePacts) r) cuts - <> maybe mempty - (\cdb -> bool - -- if rosetta is enabled but the construction API is disabled the server - -- returns a failure with a descriptive failure message instead of 404. - (bool mempty (someRosettaConstructionDeprecationServer v) r) - (someRosettaConstructionServer v concreteMs concretePacts cdb) - rc - ) - cuts -- <> maybe mempty (someSpvServers v) cuts -- AFAIK currently not used -- GET Cut, Payload, and Headers endpoints @@ -401,10 +382,6 @@ someServiceApiServer v dbs pacts mr (HeaderStream hs) (Rosetta r rc) backupEnv p <> maybe mempty (someBlockStreamServer v) (bool Nothing cuts hs) where cuts = _chainwebServerCutDb dbs - peers = _chainwebServerPeerDbs dbs - concreteMs = second PactAPI._pactServerDataMempool <$> pacts - concretePacts = second PactAPI._pactServerDataPact <$> pacts - cutPeerDb = fromJuste $ lookup CutNetwork peers payloads = _chainwebServerPayloadDbs dbs blocks = _chainwebServerBlockHeaderDbs dbs @@ -417,14 +394,13 @@ serviceApiApplication -> [(ChainId, PactAPI.PactServerData logger tbl)] -> Maybe (MiningCoordination logger tbl) -> HeaderStream - -> Rosetta -> Maybe (BackupEnv logger) -> PayloadBatchLimit -> Application -serviceApiApplication v dbs pacts mr hs r be pbl +serviceApiApplication v dbs pacts mr hs be pbl = chainwebServiceMiddlewares . someServerApplication - $ someServiceApiServer v dbs pacts mr hs r be pbl + $ someServiceApiServer v dbs pacts mr hs be pbl serveServiceApiSocket :: Show t @@ -437,11 +413,9 @@ serveServiceApiSocket -> [(ChainId, PactAPI.PactServerData logger tbl)] -> Maybe (MiningCoordination logger tbl) -> HeaderStream - -> Rosetta -> Maybe (BackupEnv logger) -> PayloadBatchLimit -> Middleware -> IO () -serveServiceApiSocket s sock v dbs pacts mr hs r be pbl m = - runSettingsSocket s sock $ m $ serviceApiApplication v dbs pacts mr hs r be pbl - +serveServiceApiSocket s sock v dbs pacts mr hs be pbl m = + runSettingsSocket s sock $ m $ serviceApiApplication v dbs pacts mr hs be pbl diff --git a/src/Chainweb/Rosetta/Internal.hs b/src/Chainweb/Rosetta/Internal.hs deleted file mode 100644 index 68658a2a6e..0000000000 --- a/src/Chainweb/Rosetta/Internal.hs +++ /dev/null @@ -1,876 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module: Chainweb.Rosetta.Internal --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: MIT --- Maintainer: Linda Ortega --- Stability: experimental --- --- -module Chainweb.Rosetta.Internal where - -import Control.Error.Util -import Control.Exception.Safe (try) -import Control.Lens hiding ((??), from, to) -import Control.Monad (foldM) -import Control.Monad.Except (throwError) -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Map (Map) -#if MIN_VERSION_base(4,20,0) -import Data.List (find) -#else -import Data.List (foldl', find) -#endif -import Data.Decimal -import Data.Word (Word64) - - -import qualified Data.DList as DList -import qualified Data.HashMap.Strict as HM -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Set as S - -import qualified Pact.Parse as P -import qualified Pact.Types.Capability as P -import qualified Pact.Types.Command as P -import qualified Pact.Types.Runtime as P - -import Pact.Types.Command -import Pact.Types.Hash -import Pact.Types.Info (noInfo) -import Pact.Types.Runtime (TxId(..)) -import Pact.Types.Persistence (RowKey(..)) -import Pact.Types.PactValue -import qualified Pact.Core.Persistence as Pact5 - -import Rosetta -import Servant.Server - --- internal modules - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.ChainId -import Chainweb.Cut -import Chainweb.CutDB -import Chainweb.Pact.Types -import Chainweb.Payload hiding (Transaction(..)) -import Chainweb.Payload.PayloadStore -import Chainweb.Rosetta.Utils -import Chainweb.TreeDB (seekAncestor) -import Chainweb.Utils -import Chainweb.Version -import Chainweb.WebPactExecutionService (PactExecutionService(..)) - -import Chainweb.Storage.Table -import qualified Pact.Core.Names as Pact5 - ---- - --------------------------------------------------------------------------------- --- Internal Helper Types and Typeclasses -- --------------------------------------------------------------------------------- - -data LogType tx where - FullLogs :: LogType [Transaction] - -- ^ Signals wanting all Rosetta Transactions - SingleLog :: RequestKey -> LogType Transaction - -- ^ Signals wanting only a single Rosetta Transaction - -data TxAccumulator rosettaTx = TxAccumulator - { _txAccumulator_logsLeft :: ![(TxId, [AccountLog])] - -- ^ Logs left to be matched - , _txAccumulator_lastSeen :: !rosettaTx - -- ^ Last Rosetta Transaction(s) seen so far - } - -data AccumulatorType rosettaTx where - AppendTx :: AccumulatorType (TxAccumulator (DList.DList Transaction)) - -- ^ Signals wanting to keep track of all the Rosetta Transactions seen so far. - Overwrite :: AccumulatorType (TxAccumulator Transaction) - -- ^ Signals wanting to only keep track of the latest Rosetta Transaction seen so far. - -accumulatorFunction - :: AccumulatorType (TxAccumulator rosettaTx) - -> TxAccumulator rosettaTx - -> [(TxId, [AccountLog])] - -> Transaction - -> TxAccumulator rosettaTx -accumulatorFunction typ prevAcc logsLeft lastSeen = newAcc - where - TxAccumulator _ prevLastSeen = prevAcc - f = case typ of - AppendTx -> DList.snoc - Overwrite -> (\_last next -> next) - newAcc = TxAccumulator logsLeft (f prevLastSeen lastSeen) - --------------------------------------------------------------------------------- --- Transaction Log Matching Functions -- --------------------------------------------------------------------------------- - --- | Retrieve the coin contract logs for transaction(s) in a block. -matchLogs - :: LogType tx - -> BlockHeader - -> M.Map TxId [AccountLog] - -> CoinbaseTx (CommandResult Hash) - -> V.Vector (CommandResult Hash) - -> ExceptT RosettaFailure Handler tx -matchLogs typ bh logs coinbase txs - | bheight == genesisHeight v cid = matchGenesis - | Just Pact4Upgrade{_pact4UpgradeTransactions = upgradeTxs} - <- v ^? versionUpgrades . atChain cid . at bheight . _Just - = matchRemediation upgradeTxs - -- TODO: integrate pact 5? - | otherwise = matchRest - where - bheight = view blockHeight bh - cid = view blockChainId bh - v = _chainwebVersion bh - - matchGenesis = hoistEither $ case typ of - FullLogs -> genesisTransactions logs cid txs - SingleLog rk -> genesisTransaction logs cid txs rk - - matchRemediation upgradeTxs = do - hoistEither $ case typ of - FullLogs -> - overwriteError RosettaMismatchTxLogs $! - remediations logs cid coinbase upgradeTxs txs - SingleLog rk -> - (noteOptional RosettaTxIdNotFound . - overwriteError RosettaMismatchTxLogs) $ - singleRemediation logs cid coinbase upgradeTxs txs rk - - matchRest = hoistEither $ case typ of - FullLogs -> - overwriteError RosettaMismatchTxLogs $ - nonGenesisTransactions logs cid coinbase txs - SingleLog rk -> - (noteOptional RosettaTxIdNotFound . - overwriteError RosettaMismatchTxLogs) $ - nonGenesisTransaction logs cid coinbase txs rk - ---------------------- --- Genesis Helpers -- ---------------------- - --- | Using its TxId, lookup a genesis transaction's coin table logs (if any) in block's --- map of all coin table logs. --- NOTE: Genesis transactions do not have coinbase or gas payments. -getGenesisLog - :: Map TxId [AccountLog] - -> ChainId - -> CommandResult Hash - -> Transaction -getGenesisLog logs cid cr = - case _crTxId cr of - Just tid -> case M.lookup tid logs of - Just l -> rosettaTransaction cr cid $! makeOps l - Nothing -> rosettaTransaction cr cid [] -- not a coin contract tx - Nothing -> rosettaTransaction cr cid [] -- all genesis tx should have a txid - where - makeOps l = indexedOperations $! - UnindexedOperations - { _unindexedOperation_fundOps = [] - , _unindexedOperation_transferOps = - map (operation Successful TransferOrCreateAcct) l - , _unindexedOperation_gasOps = [] - } - --- | Matches all genesis transactions to their coin contract logs. -genesisTransactions - :: Map TxId [AccountLog] - -> ChainId - -> V.Vector (CommandResult Hash) - -> Either RosettaFailure [Transaction] -genesisTransactions logs cid txs = - pure $ V.toList $ V.map (getGenesisLog logs cid) txs - --- | Matches a single genesis transaction to its coin contract logs. -genesisTransaction - :: Map TxId [AccountLog] - -> ChainId - -> V.Vector (CommandResult Hash) - -> RequestKey - -- ^ target tx - -> Either RosettaFailure Transaction -genesisTransaction logs cid rest target = do - cr <- note RosettaTxIdNotFound $ - V.find (\c -> _crReqKey c == target) rest - pure $ getGenesisLog logs cid cr - ------------------------- --- Coinbase Helpers -- ------------------------- - --- | Matches the first coin contract logs to the coinbase tx -nonGenesisCoinbaseLog - :: PendingRosettaTx chainwebTx - => [(TxId, [AccountLog])] - -> ChainId - -> CoinbaseTx chainwebTx - -> Either String (TxAccumulator Transaction) -nonGenesisCoinbaseLog logs cid cr = case getSomeTxId cr of - Nothing -> makeAcc logs [] - Just tid -> case logs of - (coinbaseTid,coinbaseLog):restLogs - | tid == coinbaseTid -> - makeAcc restLogs - (map (operation Successful CoinbaseReward) coinbaseLog) - | otherwise -> Left "First log's TxId does not match coinbase tx's TxId" - _ -> Left "Expected coinbase log: Received empty logs list" - - where - makeAcc restLogs ops = - let tx = makeRosettaTx cr cid $! indexedOperations $! - UnindexedOperations - { _unindexedOperation_fundOps = [] - , _unindexedOperation_transferOps = ops - , _unindexedOperation_gasOps = [] - } - in pure $ TxAccumulator restLogs tx - ------------------------- --- NonGenesis Helpers -- ------------------------- - --- Motivation: Facilitate testing matching functions with non-CommandResult types. -class PendingRosettaTx chainwebTx where - getSomeTxId :: chainwebTx -> Maybe TxId - getRequestKey :: chainwebTx -> RequestKey - makeRosettaTx :: chainwebTx -> ChainId -> [Operation] -> Transaction - -instance PendingRosettaTx (CommandResult a) where - getSomeTxId = _crTxId - getRequestKey = _crReqKey - makeRosettaTx = rosettaTransaction - --- | For a given tx, accumulates a triple of logs representing said tx's bracketing gas logs --- and any coin contract logs caused by the tx itself (i.e. transfers, create-accounts). --- Algorithm: --- (1) Peek at the first two logs in the logs list. --- (2) Assume the first log out of the two peeked funded the tx. --- (3) Label as "unknown" the second log peeked for now. --- It could be a gas or transfer logs, but more information is needed. --- (4) Check if the tx has a TxId (i.e. was the tx successful or not). --- (5) If the tx is unsuccessful and thus does not have a TxId, then it --- wouldn't have any transfer logs. Thus, label the peeked "unknown" log (1) --- as a gas payment log. --- (6) But if the tx is successful and thus has a TxId, check whether this TxId --- matches the TxId associated with the "unknown" peeked log (1). --- (7) If the TxIds match, then label the "unknown" peeked log (1) as a transfer log. --- And peek at the next log in the logs list and label it as a gas payment log. --- (8) If the TxIds don't match, then the tx did not interact with the coin contract --- and thus the "unknown" peeked logs (1) are gas payment logs. -gasTransactionAcc - :: PendingRosettaTx chainwebTx - => AccumulatorType (TxAccumulator rosettaTxAcc) - -> ChainId - -> TxAccumulator rosettaTxAcc - -> chainwebTx - -> Either String (TxAccumulator rosettaTxAcc) -gasTransactionAcc accTyp cid acc ctx = combine (_txAccumulator_logsLeft acc) - where - combine (fundLog:someLog:restLogs) = - case getSomeTxId ctx of - Nothing -> -- tx was unsuccessful - makeAcc restLogs - (makeOps FundTx fundLog) - [] -- no transfer logs - (makeOps GasPayment someLog) - Just tid -- tx was successful - | tid /= txId someLog -> -- if tx didn't touch coin table - makeAcc restLogs - (makeOps FundTx fundLog) - [] -- no transfer logs - (makeOps GasPayment someLog) - | otherwise -> case restLogs of - gasLog:restLogs' -> -- if tx DID touch coin table - makeAcc restLogs' - (makeOps FundTx fundLog) - (makeOps TransferOrCreateAcct someLog) - (makeOps GasPayment gasLog) - l -> listErr "No gas logs found after transfer logs" l - combine [f] = listErr "Only fund logs found" f - combine [] = listErr "No logs found" ([] :: [(TxId, [AccountLog])]) - - makeAcc restLogs fund transfer gas = pure $! - accumulatorFunction accTyp acc restLogs tx - where - tx = makeRosettaTx ctx cid $! indexedOperations $! - UnindexedOperations - { _unindexedOperation_fundOps = fund - , _unindexedOperation_transferOps = transfer - , _unindexedOperation_gasOps = gas - } - - txId (tid,_) = tid - - makeOps ot (_, als) = - map (operation Successful ot) als - - listErr expectedMsg logs = Left $ - expectedMsg ++ ": Received logs list " ++ show logs - - --- | Matches all transactions in a non-genesis block to their coin contract logs. --- The first transaction in non-genesis blocks is the coinbase transaction. --- Each transactions that follows has (1) logs that fund the transaction, --- (2) optional tx specific coin contract logs, and (3) logs that pay gas. --- TODO: Max limit of tx to return at once. --- When to do pagination using /block/transaction? -nonGenesisTransactions - :: PendingRosettaTx chainwebTx - => Map TxId [AccountLog] - -> ChainId - -> CoinbaseTx chainwebTx - -> V.Vector chainwebTx - -> Either String [Transaction] -nonGenesisTransactions logs cid initial rest = do - TxAccumulator restLogs initTx <- nonGenesisCoinbaseLog logsList cid initial - TxAccumulator _ ts <- foldM match (defAcc restLogs initTx) rest - pure $ DList.toList ts - where - logsList = M.toAscList logs - match = gasTransactionAcc AppendTx cid - defAcc li tx = TxAccumulator li (DList.singleton tx) - - --- | Matches a single non-genesis transaction to its coin contract logs --- if it exists in the given block. -nonGenesisTransaction - :: PendingRosettaTx chainwebTx - => Map TxId [AccountLog] - -> ChainId - -> CoinbaseTx chainwebTx - -> V.Vector chainwebTx - -> RequestKey - -- ^ Lookup target - -> Either String (Maybe Transaction) -nonGenesisTransaction logs cid initial rest target - | getRequestKey initial == target = do - -- Looking for coinbase tx - TxAccumulator _ initTx <- nonGenesisCoinbaseLog logsList cid initial - pure $ Just initTx - | otherwise = do - -- Traverse list matching transactions to their logs. - -- If target's logs found or if error throw by matching function, - -- short circuit. - TxAccumulator restLogs initTx <- nonGenesisCoinbaseLog logsList cid initial - let acc = TxAccumulator restLogs initTx - fromShortCircuit $ foldM findTxAndLogs acc rest - - where - logsList = M.toAscList logs - match = gasTransactionAcc Overwrite cid - - findTxAndLogs acc cr = do - TxAccumulator logsLeft lastSeenTx <- shortCircuit (match acc cr) - if getRequestKey cr == target - then Left $ Right lastSeenTx - -- short-circuit if find target tx's logs - else pure (TxAccumulator logsLeft lastSeenTx) - -- continue matching other txs' logs until find target - - shortCircuit - :: Either String (TxAccumulator Transaction) - -> Either (Either String Transaction) (TxAccumulator Transaction) - shortCircuit (Left e) = Left $ Left e - -- short-circuit if matching function threw error - shortCircuit (Right r) = Right r - - fromShortCircuit - :: Either (Either String Transaction) (TxAccumulator Transaction) - -> Either String (Maybe Transaction) - fromShortCircuit (Right _) = pure Nothing - -- Tx not found - fromShortCircuit (Left (Left s)) = Left s - fromShortCircuit (Left (Right tx)) = pure (Just tx) - -- Tx found - -------------------------- --- Remediation Helpers -- -------------------------- - --- | Given a remediation Command and its assumed TxId: --- Query the latest coin table log in the list. --- If the TxId of this coin table log matches the remediation's TxId, --- then assumes that this log corresponds to the given remediation. --- Otherwise, a rosetta transaction is created for the given --- remediation with an empty operations list. --- NOTE: Assumes that each remediation must have been successful and thus --- would have a TxId associated with it. --- NOTE: Not all remediations transactions will output coin table logs. -remediationAcc - :: AccumulatorType (TxAccumulator rosettaTx) - -> TxAccumulator rosettaTx - -> (Command payload, TxId) - -> TxAccumulator rosettaTx -remediationAcc accTyp acc (remTx, remTid) = - case _txAccumulator_logsLeft acc of - (logTid,logs):rest - | logTid == remTid -> -- remediation touched coin table - let ops = indexedOperations $! - UnindexedOperations - { _unindexedOperation_fundOps = [] - , _unindexedOperation_transferOps = makeOps logs - , _unindexedOperation_gasOps = [] - } - rosettaTx = rosettaTransactionFromCmd remTx $! ops - in makeAcc rest rosettaTx - rest -> -- list of logs empty or remediation didn't touch coin table - makeAcc rest $! - rosettaTransactionFromCmd remTx [] - where - makeAcc restLogs rosettaTx = - accumulatorFunction accTyp acc restLogs rosettaTx - makeOps logs = - map (operation Remediation TransferOrCreateAcct) logs - --- | Matches all transactions in a remediation block --- (including coinbase, remediations, and user transactions) --- to their coin table logs. --- Coinbase logs are matched first, followed by remediations txs, --- and finally user transactions are matched using the same algorithm --- as non-genesis transactions. --- NOTE: Assumes that each remediation transaction incremented --- the TxId counter by one. --- NOTE: Assumes remediations don't occur in blocks where coinbase transaction --- could have failed. It needs to know the TxId of the coinbase transaction in --- order to derive the remediation's TxIds. -remediations - :: Map TxId [AccountLog] - -> ChainId - -> CoinbaseTx (CommandResult Hash) - -- Remediation transactions. - -- NOTE: No CommandResult available for these. - -> [Command payload] - -- User transactions in the same block as remediations - -> V.Vector (CommandResult Hash) - -> Either String [Transaction] -remediations logs cid coinbase remTxs txs = do - TxAccumulator restLogs coinbaseTx <- nonGenesisCoinbaseLog logsList cid coinbase - coinbaseTxId <- note "remediations: No TxId found for Coinbase" (_crTxId coinbase) - - let remWithTxIds = zip remTxs [(succ coinbaseTxId)..] - -- Assumes that each remediation transaction gets its own TxId. - -- Assumes that TxIds are going to be sequential for each remediation. - - -- Note (linda and emily): This assumption holds, since the remediation txs are - -- applied directly after coinbase at a particular height, as part of applyCoinbase. - -- We construct the blocks, hence, the txids are not random. - -- See for more details: - -- https://github.com/kadena-io/chainweb-node/blob/c0c300a64040390d603f1183eac126e3bbfebe8d/src/Chainweb/Pact/TransactionExec.hs#L328 - - accWithCoinbase = TxAccumulator restLogs (DList.singleton coinbaseTx) - accWithRems = foldl' matchRem accWithCoinbase remWithTxIds - - TxAccumulator _ ts <- foldM matchOtherTxs accWithRems txs - pure $ DList.toList ts - - where - logsList = M.toAscList logs - matchRem = remediationAcc AppendTx - matchOtherTxs = gasTransactionAcc AppendTx cid - - --- | Matches a single request key to its coin table logs in a block --- with remediations. -singleRemediation - :: Map TxId [AccountLog] - -> ChainId - -> CoinbaseTx (CommandResult Hash) - -> [Command payload] - -- ^ Remediation transactions. - -- ^ NOTE: No CommandResult available for these. - -> V.Vector (CommandResult Hash) - -- ^ User transactions in the same block as remediations - -> RequestKey - -- ^ target - -> Either String (Maybe Transaction) -singleRemediation logs cid coinbase remTxs txs rkTarget = do - rosettaTxs <- remediations logs cid coinbase remTxs txs - pure $ find isTargetTx rosettaTxs - -- TODO: Make searching for tx and its logs more efficient. - where - isTargetTx rtx = - rkToTransactionId rkTarget == _transaction_transactionId rtx - --------------------------------------------------------------------------------- --- Chainweb Helper Functions -- --------------------------------------------------------------------------------- - -getLatestBlockHeader - :: CutDb tbl - -> ChainId - -> ExceptT RosettaFailure Handler BlockHeader -getLatestBlockHeader cutDb cid = do - c <- liftIO $ _cut cutDb - HM.lookup cid (_cutMap c) ?? RosettaInvalidChain - -findBlockHeaderInCurrFork - :: CutDb tbl - -> ChainId - -> Maybe Word64 - -- ^ Block Height - -> Maybe T.Text - -- ^ Block Hash - -> ExceptT RosettaFailure Handler BlockHeader -findBlockHeaderInCurrFork cutDb cid someHeight someHash = do - latestBlock <- getLatestBlockHeader cutDb cid - chainDb <- (cutDb ^? cutDbBlockHeaderDb cid) ?? RosettaInvalidChain - - case (someHeight, someHash) of - (Nothing, Nothing) -> pure latestBlock - (Just hi, Nothing) -> byHeight chainDb latestBlock hi - (Just hi, Just hsh) -> do - bh <- byHeight chainDb latestBlock hi - bhashExpected <- blockHashFromText hsh ?? RosettaUnparsableBlockHash - if view blockHash bh == bhashExpected - then pure bh - else throwError RosettaMismatchBlockHashHeight - (Nothing, Just hsh) -> do - bhash <- blockHashFromText hsh ?? RosettaUnparsableBlockHash - somebh <- liftIO (tableLookup chainDb bhash) - bh <- somebh ?? RosettaBlockHashNotFound - isInCurrFork <- liftIO $ memberOfHeader cutDb cid bhash latestBlock - if isInCurrFork - then pure bh - else throwError RosettaOrphanBlockHash - where - byHeight db latest hi = do - somebh <- liftIO $ seekAncestor db latest (int hi) - somebh ?? RosettaInvalidBlockHeight - -getBlockOutputs - :: forall tbl - . CanReadablePayloadCas tbl - => PayloadDb tbl - -> BlockHeader - -> ExceptT RosettaFailure Handler (CoinbaseTx (CommandResult Hash), V.Vector (CommandResult Hash)) -getBlockOutputs payloadDb bh = do - someOut <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ view blockHeight bh) (view blockPayloadHash bh) - outputs <- someOut ?? RosettaPayloadNotFound - txsOut <- decodeTxsOut outputs ?? RosettaUnparsableTxOut - coinbaseOut <- decodeCoinbaseOut outputs ?? RosettaUnparsableTxOut - pure (coinbaseOut, txsOut) - - where - decodeCoinbaseOut :: PayloadWithOutputs -> Maybe (CommandResult Hash) - decodeCoinbaseOut = decodeStrictOrThrow . _coinbaseOutput . _payloadWithOutputsCoinbase - - decodeTxsOut :: PayloadWithOutputs -> Maybe (V.Vector (CommandResult Hash)) - decodeTxsOut pwo = mapM (decodeStrictOrThrow . _transactionOutputBytes . snd) - (_payloadWithOutputsTransactions pwo) - -getTxLogs - :: PactExecutionService - -> BlockHeader - -> ExceptT RosettaFailure Handler (Map TxId [AccountLog]) -getTxLogs cr bh = do - exnOrSomeHist <- liftIO $ try @_ @PactException $ _pactBlockTxHistory cr bh d - someHist <- hush exnOrSomeHist ?? RosettaPactExceptionThrown - BlockTxHistory hist prevTxs <- case someHist of - NoHistory -> throwError RosettaTxIdNotFound - Historical hist -> return hist - lastBalSeen <- hoistEither $ parsePrevTxs prevTxs - histAcctRow <- hoistEither $ parseHist hist - pure $ getBalanceDeltas histAcctRow lastBalSeen - where - d = Pact5.DUserTables (Pact5.TableName "coin-table" (Pact5.ModuleName "coin" Nothing)) - - parseHist - :: Map TxId [Pact5.TxLog Pact5.RowData] - -> Either RosettaFailure (Map TxId [AccountRow]) - parseHist m - | M.size parsed == M.size m = pure $! parsed - | otherwise = throwError RosettaUnparsableTxLog - where - parsed = M.mapMaybe (mapM txLogToAccountRow) m - - parsePrevTxs - :: Map RowKey (Pact5.TxLog Pact5.RowData) - -> Either RosettaFailure (Map RowKey AccountRow) - parsePrevTxs m - | M.size parsed == M.size m = pure $! parsed - | otherwise = throwError RosettaUnparsableTxLog - where - parsed = M.mapMaybe txLogToAccountRow m - -getBalanceDeltas - :: Map TxId [AccountRow] - -> Map RowKey AccountRow - -> Map TxId [AccountLog] -getBalanceDeltas hist lastBalsSeenDef = - snd $! M.mapAccumWithKey f lastBalsSeenDef hist - where - -- | For given txId and the rows it affected, calculate - -- | how each row key has changed since previously seen. - -- | Adds or updates map of previously seen rows with each - -- | of this txId's rows. - f - :: Map RowKey AccountRow - -> TxId - -> [AccountRow] - -> (Map RowKey AccountRow, [AccountLog]) - f lastBals _txId currRows = (updatedBals, reverse logs) - where - (updatedBals, logs) = foldl' helper (lastBals, []) currRows - helper (bals, li) row = (bals', li') - where - (bals', acctLog) = lookupAndUpdate bals row - li' = acctLog:li -- needs to be reversed at the end - - -- | Lookup current row key in map of previous seen rows - -- | to calculate how row has changed. - -- | Adds or updates the map of previously seen rows with - -- | the current row. - lookupAndUpdate - :: Map RowKey AccountRow - -> AccountRow - -> (Map RowKey AccountRow, AccountLog) - lookupAndUpdate lastBals currRow = (lastBals', acctLog) - where - (key, _, _) = currRow - (prevRow, lastBals') = - M.insertLookupWithKey - lookupAndReplace - (RowKey key) - currRow - lastBals - acctLog = rowDataToAccountLog currRow prevRow - lookupAndReplace _key new _old = new - - --- | Lookup the row value of a coin-contract key --- at a given block. -getHistoricalLookupBalance' - :: PactExecutionService - -> BlockHeader - -> T.Text - -> ExceptT RosettaFailure Handler (Maybe AccountRow) -getHistoricalLookupBalance' cr bh k = do - hist <- liftIO (_pactHistoricalLookup cr bh d key) >>= \case - NoHistory -> throwError (RosettaTxIdNotFound) - Historical hist -> return hist - case hist of - Nothing -> pure Nothing - Just h -> do - row <- txLogToAccountRow h ?? RosettaUnparsableTxLog - pure $ Just row - where - d = Pact5.DUserTables (Pact5.TableName "coin-table" (Pact5.ModuleName "coin" Nothing)) - key = Pact5.RowKey k -- TODO: How to sanitize this further - -getHistoricalLookupBalance - :: PactExecutionService - -> BlockHeader - -> T.Text - -> ExceptT RosettaFailure Handler Decimal -getHistoricalLookupBalance cr bh k = do - someRow <- getHistoricalLookupBalance' cr bh k - case someRow of - Nothing -> pure 0.0 -- key not present - Just (_,bal,_) -> pure bal - - -rosettaErrorT - :: Maybe String - -> ExceptT RosettaFailure Handler a - -> ExceptT RosettaError Handler a -rosettaErrorT someMsg = mapExceptT f - where - f :: Handler (Either RosettaFailure b) - -> Handler (Either RosettaError b) - f run = do - eitherRes <- run - case eitherRes of - Left failure -> - case someMsg of - Nothing -> pure $ Left $ rosettaError' failure - Just msg -> pure $ Left $ stringRosettaError failure msg - Right r -> pure $ Right r - - -neededAccounts - :: ConstructionTx - -> AccountId - -> [AccountId] -neededAccounts txInfo payerAcct = S.toList $ - case txInfo of - ConstructTransfer from _ _ _ _ -> - S.insert from m - where - -- Uses Sets to avoid repeating accounts - -- (i.e. the gas payer is the same as the transfer) - m = S.singleton payerAcct - - --- | Iterates through the `ConstructionTx` to determine --- the accounts needed for signing, determines their required --- capabilities, and queries the blockchain to determine the keys --- associated with said accounts. -toSignerAcctsMap - :: ConstructionTx - -> AccountId - -> ChainId - -> [(ChainId, PactExecutionService)] - -> CutDb tbl - -> ExceptT RosettaError Handler - (HM.HashMap AccountId ([P.SigCapability], [T.Text])) -toSignerAcctsMap txInfo payerAcct cid pacts cutDb = do - bhCurr <- rosettaErrorT Nothing $ - getLatestBlockHeader cutDb cid - peCurr <- rosettaErrorT Nothing $ - lookup cid pacts ?? RosettaInvalidChain - - -- GAS - someGasOwner <- getOwnership peCurr bhCurr payerAcct - gasOwner <- enforceAcctPresent payerAcct someGasOwner - let gasCaps = [ mkGasCap ] - mapWithGas = HM.singleton - payerAcct - (gasCaps, gasOwner) - - -- TRANSACTION - case txInfo of - ConstructTransfer from fromGuard to toGuard (P.ParsedDecimal amt) -> do - let expectedFrom = ksToPubKeys fromGuard - -- `to` acount could be getting created - expectedTo = ksToPubKeys toGuard - - someActualFrom <- getOwnership peCurr bhCurr from - someActualTo <- getOwnership peCurr bhCurr to - - _ <- enforceAcctPresent from someActualFrom - checkExpectedOwnership from expectedFrom someActualFrom - checkExpectedOwnership to expectedTo someActualTo - - let capsFrom = [ mkTransferCap from to amt ] - - pure $ insertWith' from (capsFrom, expectedFrom) mapWithGas - where - getOwnership cr bh k = do - someRow <- rosettaErrorT Nothing $ - getHistoricalLookupBalance' cr bh (_accountId_address k) - case someRow of - Nothing -> pure Nothing - Just (_,_,g) -> hoistEither $ Just <$> parsePubKeys (_accountId_address k) g - - insertWith' - :: AccountId - -> ([P.SigCapability], [T.Text]) - -> HM.HashMap AccountId ([P.SigCapability], [T.Text]) - -> HM.HashMap AccountId ([P.SigCapability], [T.Text]) - insertWith' acct sigs m = HM.insertWith f acct sigs m - where - f (newSigs, _) (oldSigs, oldKeys) = - (oldSigs <> newSigs, oldKeys) -- keys wouldn't change - - -- Cap smart constructor. - mkCapability - :: P.ModuleName - -> T.Text - -> [PactValue] - -> P.SigCapability - mkCapability mn cap args = - P.SigCapability (P.QualifiedName mn cap noInfo) args - - -- Convenience to make caps like TRANSFER, GAS etc. - mkCoinCap - :: T.Text - -> [PactValue] - -> P.SigCapability - mkCoinCap n = mkCapability "coin" n - - mkTransferCap - :: AccountId - -> AccountId - -> Decimal - -> P.SigCapability - mkTransferCap sender receiver amount = mkCoinCap "TRANSFER" - [ pString (_accountId_address sender), - pString (_accountId_address receiver), - pDecimal amount ] - - mkGasCap :: P.SigCapability - mkGasCap = mkCoinCap "GAS" [] - - -- Make PactValue from text - pString :: T.Text -> PactValue - pString = PLiteral . P.LString - - -- Make PactValue from decimal - pDecimal :: Decimal -> PactValue - pDecimal = PLiteral . P.LDecimal - -enforceAcctPresent - :: AccountId - -> Maybe [T.Text] - -> ExceptT RosettaError Handler [T.Text] -enforceAcctPresent k actualOwnership = - case actualOwnership of - Just pks -> pure pks - Nothing -> -- key missing (not expected) - hoistEither $ Left $ - stringRosettaError RosettaInvalidAccountProvided $ - "Account=" ++ show k ++ " doesn't exists" - -checkExpectedOwnership - :: AccountId - -> [T.Text] - -> Maybe [T.Text] - -> ExceptT RosettaError Handler () -checkExpectedOwnership _ _ Nothing = pure () -checkExpectedOwnership acct expected (Just actual) - | expected == actual = pure () - | otherwise = hoistEither $ Left $ - stringRosettaError RosettaInvalidAccountProvided $ - "Account=" ++ show acct ++ ": Provided public key addresses " - ++ show expected ++ - " doesn't match the account's actual public key addresses " - ++ show actual - --- | Maps a Pact Address (derived from PublicKey) to a --- function to create a Signer. -rosettaPubKeysToSignerMap - :: [RosettaPublicKey] - -> Either RosettaError (HM.HashMap T.Text ([P.SigCapability] -> Signer)) -rosettaPubKeysToSignerMap pubKeys = HM.fromList <$> mapM f pubKeys - where - f (RosettaPublicKey pk ct) = do - sk <- getScheme ct - addr <- toPactPubKeyAddr pk - let signerWithoutCap = P.Signer (Just sk) pk (Just addr) - pure (addr, signerWithoutCap) - -createSigners - :: HM.HashMap T.Text ([P.SigCapability] -> Signer) - -> HM.HashMap AccountId ([P.SigCapability], [T.Text]) - -> Either RosettaError [(Signer, AccountId)] -createSigners addrToSignerMap acctToCapMap = - -- NOTE: There might be duplicates signers but that's okay - concat <$> mapM f (HM.toList acctToCapMap) - where - f (acct, (caps, pubKeyAddrs)) = - mapM (lookupSigner acct caps) pubKeyAddrs - - lookupSigner :: AccountId -> [P.SigCapability] -> T.Text -> Either RosettaError (Signer, AccountId) - lookupSigner acct caps pkAddr = do - mkSigner <- toRosettaError RosettaMissingExpectedPublicKey $ - note ("No Rosetta Public Key found for pact public key address=" - ++ show pkAddr ++ " for AccountId=" ++ show acct) - (HM.lookup pkAddr addrToSignerMap) - pure (mkSigner caps, acct) diff --git a/src/Chainweb/Rosetta/RestAPI.hs b/src/Chainweb/Rosetta/RestAPI.hs deleted file mode 100644 index 56ccbfeffd..0000000000 --- a/src/Chainweb/Rosetta/RestAPI.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module: Chainweb.Rosetta.RestAPI --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: MIT --- Maintainer: Colin Woodbury --- Stability: experimental --- --- -module Chainweb.Rosetta.RestAPI - ( -- * Endpoints - RosettaApi - , rosettaApi - , RosettaConstructionApi - , rosettaConstructionApi - -- * Standalone APIs for client derivation - , RosettaAccountBalanceApi - , rosettaAccountBalanceApi - , RosettaBlockTransactionApi - , rosettaBlockTransactionApi - , RosettaBlockApi - , rosettaBlockApi - , RosettaConstructionDeriveApi - , rosettaConstructionDeriveApi - , RosettaConstructionPreprocessApi - , rosettaConstructionPreprocessApi - , RosettaConstructionMetadataApi - , rosettaConstructionMetadataApi - , RosettaConstructionPayloadsApi - , rosettaConstructionPayloadsApi - , RosettaConstructionParseApi - , rosettaConstructionParseApi - , RosettaConstructionCombineApi - , rosettaConstructionCombineApi - , RosettaConstructionHashApi - , rosettaConstructionHashApi - , RosettaConstructionSubmitApi - , rosettaConstructionSubmitApi - , RosettaMempoolTransactionApi - , rosettaMempoolTransactionApi - , RosettaMempoolApi - , rosettaMempoolApi - , RosettaNetworkListApi - , rosettaNetworkListApi - , RosettaNetworkOptionsApi - , rosettaNetworkOptionsApi - , RosettaNetworkStatusApi - , rosettaNetworkStatusApi - -- * Errors - , throwRosetta - , throwRosettaError - , validateNetwork - ) where - -import Control.Error.Util -import Control.Monad - -import Rosetta - -import Servant - --- internal modules - -import Chainweb.ChainId -import Chainweb.Rosetta.Utils -import Chainweb.RestAPI.Utils -import Chainweb.Version - ---- - --- ------------------------------------------------------------------ -- --- Rosetta Api - -type RosettaApi (v :: ChainwebVersionT) = 'ChainwebEndpoint v :> Reassoc RosettaApi_ - -type RosettaApi_ = "rosetta" :> - ( -- Accounts -- - RosettaAccountBalanceApi_ - -- Blocks -- - :<|> RosettaBlockTransactionApi_ - :<|> RosettaBlockApi_ - -- Mempool -- - :<|> RosettaMempoolTransactionApi_ - :<|> RosettaMempoolApi_ - -- Network -- - :<|> RosettaNetworkListApi_ - :<|> RosettaNetworkOptionsApi_ - :<|> RosettaNetworkStatusApi_ - ) - -rosettaApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaApi v) -rosettaApi = Proxy - --- ------------------------------------------------------------------ -- --- Rosetta Construction Api - -type RosettaConstructionApi (v :: ChainwebVersionT) = 'ChainwebEndpoint v :> Reassoc RosettaConstructionApi_ - -type RosettaConstructionApi_ = "rosetta" :> - ( RosettaConstructionDeriveApi_ - :<|> RosettaConstructionPreprocessApi_ - :<|> RosettaConstructionMetadataApi_ - :<|> RosettaConstructionPayloadsApi_ - :<|> RosettaConstructionParseApi_ - :<|> RosettaConstructionCombineApi_ - :<|> RosettaConstructionHashApi_ - :<|> RosettaConstructionSubmitApi_ - ) - -rosettaConstructionApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionApi v) -rosettaConstructionApi = Proxy - --- ------------------------------------------------------------------ -- --- Standalone Endpoints + Witnesses - -type RosettaApiEndpoint (v :: ChainwebVersionT) api - = 'ChainwebEndpoint v - :> "rosetta" - :> api - -type RosettaAccountBalanceApi v = RosettaApiEndpoint v RosettaAccountBalanceApi_ -type RosettaBlockTransactionApi v = RosettaApiEndpoint v RosettaBlockTransactionApi_ -type RosettaBlockApi v = RosettaApiEndpoint v RosettaBlockApi_ -type RosettaConstructionDeriveApi v = RosettaApiEndpoint v RosettaConstructionDeriveApi_ -type RosettaConstructionPreprocessApi v = RosettaApiEndpoint v RosettaConstructionPreprocessApi_ -type RosettaConstructionMetadataApi v = RosettaApiEndpoint v RosettaConstructionMetadataApi_ -type RosettaConstructionPayloadsApi v = RosettaApiEndpoint v RosettaConstructionPayloadsApi_ -type RosettaConstructionParseApi v = RosettaApiEndpoint v RosettaConstructionParseApi_ -type RosettaConstructionCombineApi v = RosettaApiEndpoint v RosettaConstructionCombineApi_ -type RosettaConstructionHashApi v = RosettaApiEndpoint v RosettaConstructionHashApi_ -type RosettaConstructionSubmitApi v = RosettaApiEndpoint v RosettaConstructionSubmitApi_ -type RosettaMempoolTransactionApi v = RosettaApiEndpoint v RosettaMempoolTransactionApi_ -type RosettaMempoolApi v = RosettaApiEndpoint v RosettaMempoolApi_ -type RosettaNetworkListApi v = RosettaApiEndpoint v RosettaNetworkListApi_ -type RosettaNetworkOptionsApi v = RosettaApiEndpoint v RosettaNetworkOptionsApi_ -type RosettaNetworkStatusApi v = RosettaApiEndpoint v RosettaNetworkStatusApi_ - -type RosettaAccountBalanceApi_ - = "account" - :> "balance" - :> ReqBody '[JSON] AccountBalanceReq - :> Post '[JSON] AccountBalanceResp - -type RosettaBlockTransactionApi_ - = "block" - :> "transaction" - :> ReqBody '[JSON] BlockTransactionReq - :> Post '[JSON] BlockTransactionResp - -type RosettaBlockApi_ - = "block" - :> ReqBody '[JSON] BlockReq - :> Post '[JSON] BlockResp - -type RosettaConstructionDeriveApi_ - = "construction" - :> "derive" - :> ReqBody '[JSON] ConstructionDeriveReq - :> Post '[JSON] ConstructionDeriveResp - -type RosettaConstructionPreprocessApi_ - = "construction" - :> "preprocess" - :> ReqBody '[JSON] ConstructionPreprocessReq - :> Post '[JSON] ConstructionPreprocessResp - -type RosettaConstructionMetadataApi_ - = "construction" - :> "metadata" - :> ReqBody '[JSON] ConstructionMetadataReq - :> Post '[JSON] ConstructionMetadataResp - -type RosettaConstructionPayloadsApi_ - = "construction" - :> "payloads" - :> ReqBody '[JSON] ConstructionPayloadsReq - :> Post '[JSON] ConstructionPayloadsResp - -type RosettaConstructionParseApi_ - = "construction" - :> "parse" - :> ReqBody '[JSON] ConstructionParseReq - :> Post '[JSON] ConstructionParseResp - -type RosettaConstructionCombineApi_ - = "construction" - :> "combine" - :> ReqBody '[JSON] ConstructionCombineReq - :> Post '[JSON] ConstructionCombineResp - -type RosettaConstructionHashApi_ - = "construction" - :> "hash" - :> ReqBody '[JSON] ConstructionHashReq - :> Post '[JSON] TransactionIdResp - -type RosettaConstructionSubmitApi_ - = "construction" - :> "submit" - :> ReqBody '[JSON] ConstructionSubmitReq - :> Post '[JSON] TransactionIdResp - -type RosettaMempoolTransactionApi_ - = "mempool" - :> "transaction" - :> ReqBody '[JSON] MempoolTransactionReq - :> Post '[JSON] MempoolTransactionResp - -type RosettaMempoolApi_ - = "mempool" - :> ReqBody '[JSON] NetworkReq - :> Post '[JSON] MempoolResp - -type RosettaNetworkListApi_ - = "network" - :> "list" - :> ReqBody '[JSON] MetadataReq - :> Post '[JSON] NetworkListResp - -type RosettaNetworkOptionsApi_ - = "network" - :> "options" - :> ReqBody '[JSON] NetworkReq - :> Post '[JSON] NetworkOptionsResp - -type RosettaNetworkStatusApi_ - = "network" - :> "status" - :> ReqBody '[JSON] NetworkReq - :> Post '[JSON] NetworkStatusResp - -rosettaAccountBalanceApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaAccountBalanceApi v) -rosettaAccountBalanceApi = Proxy - -rosettaBlockTransactionApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaBlockTransactionApi v) -rosettaBlockTransactionApi = Proxy - -rosettaBlockApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaBlockApi v) -rosettaBlockApi = Proxy - -rosettaConstructionDeriveApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionDeriveApi v) -rosettaConstructionDeriveApi = Proxy - -rosettaConstructionPreprocessApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionPreprocessApi v) -rosettaConstructionPreprocessApi = Proxy - -rosettaConstructionMetadataApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionMetadataApi v) -rosettaConstructionMetadataApi = Proxy - -rosettaConstructionPayloadsApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionPayloadsApi v) -rosettaConstructionPayloadsApi = Proxy - -rosettaConstructionParseApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionParseApi v) -rosettaConstructionParseApi = Proxy - -rosettaConstructionCombineApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionCombineApi v) -rosettaConstructionCombineApi = Proxy - -rosettaConstructionHashApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionHashApi v) -rosettaConstructionHashApi = Proxy - -rosettaConstructionSubmitApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaConstructionSubmitApi v) -rosettaConstructionSubmitApi = Proxy - -rosettaMempoolTransactionApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaMempoolTransactionApi v) -rosettaMempoolTransactionApi = Proxy - -rosettaMempoolApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaMempoolApi v) -rosettaMempoolApi = Proxy - -rosettaNetworkListApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaNetworkListApi v) -rosettaNetworkListApi = Proxy - -rosettaNetworkOptionsApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaNetworkOptionsApi v) -rosettaNetworkOptionsApi = Proxy - -rosettaNetworkStatusApi - :: forall (v :: ChainwebVersionT) - . Proxy (RosettaNetworkStatusApi v) -rosettaNetworkStatusApi = Proxy - - -throwRosetta :: RosettaFailure -> Handler a -throwRosetta e = throwError $ setErrJSON (rosettaError e Nothing) err500 - -throwRosettaError :: RosettaError -> Handler a -throwRosettaError e = throwError $ setErrJSON e err500 - --- | Every Rosetta request that requires a `NetworkId` also requires a --- `SubNetworkId`, at least in the case of Chainweb. --- --- TODO for requests that concern only a particular block height it should --- be verified that the chain is is active at that height. --- -validateNetwork :: ChainwebVersion -> NetworkId -> Either RosettaFailure ChainId -validateNetwork v (NetworkId bc n msni) = do - when (bc /= "kadena") $ Left RosettaInvalidBlockchainName - when (_versionName v /= ChainwebVersionName n) $ Left RosettaMismatchNetworkName - SubNetworkId cid _ <- note RosettaChainUnspecified msni - note RosettaInvalidChain $ readChainIdText v cid diff --git a/src/Chainweb/Rosetta/RestAPI/Client.hs b/src/Chainweb/Rosetta/RestAPI/Client.hs deleted file mode 100644 index 8da337d0ac..0000000000 --- a/src/Chainweb/Rosetta/RestAPI/Client.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RankNTypes #-} --- | --- Module: Chainweb.Rosetta.RestAPI.Client --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: MIT --- Maintainer: Emily Pillmore --- Stability: experimental --- --- This module defines the client API for the Chainweb Rosetta --- integration. --- -module Chainweb.Rosetta.RestAPI.Client -( -- * AccounT Endpoints - rosettaAccountBalanceApiClient - -- * Block Endpoints -, rosettaBlockTransactionApiClient -, rosettaBlockApiClient - -- * Construction Endpoints -, rosettaConstructionDeriveApiClient -, rosettaConstructionPreprocessApiClient -, rosettaConstructionMetadataApiClient -, rosettaConstructionPayloadsApiClient -, rosettaConstructionParseApiClient -, rosettaConstructionCombineApiClient -, rosettaConstructionHashApiClient -, rosettaConstructionSubmitApiClient - -- * Mempool Endpoints -, rosettaMempoolApiClient -, rosettaMempoolTransactionApiClient - -- * Network Endpoints -, rosettaNetworkListApiClient -, rosettaNetworkOptionsApiClient -, rosettaNetworkStatusApiClient -) -where - - -import Rosetta - -import Servant.Client - --- internal chainweb modules - -import Chainweb.ChainId -import Chainweb.Rosetta.RestAPI -import Chainweb.Version - - --- -------------------------------------------------------------------------- -- --- Accounts Endpoints - -rosettaAccountBalanceApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => AccountBalanceReq - -- ^ Contains a network id, account id, and a partial block identifier - -- which is not populated. - -> ClientM AccountBalanceResp -rosettaAccountBalanceApiClient_ = client (rosettaAccountBalanceApi @v) - -rosettaAccountBalanceApiClient - :: ChainwebVersion - -> AccountBalanceReq - -- ^ Contains a network id, account id, and a partial block identifier - -- which is not populated. - -> ClientM AccountBalanceResp -rosettaAccountBalanceApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaAccountBalanceApiClient_ @v - --- -------------------------------------------------------------------------- -- --- Block Endpoints - -rosettaBlockTransactionApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => BlockTransactionReq - -- ^ Contains a network id, a block id, and a transaction id - -> ClientM BlockTransactionResp -rosettaBlockTransactionApiClient_ = client (rosettaBlockTransactionApi @v) - -rosettaBlockTransactionApiClient - :: ChainwebVersion - -> BlockTransactionReq - -- ^ Contains a network id, a block id, and a transaction id - -> ClientM BlockTransactionResp -rosettaBlockTransactionApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaBlockTransactionApiClient_ @v - -rosettaBlockApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => BlockReq - -- ^ Contains a network id and a partial block id - -> ClientM BlockResp -rosettaBlockApiClient_ = client (rosettaBlockApi @v) - -rosettaBlockApiClient - :: ChainwebVersion - -> BlockReq - -- ^ Contains a network id and a partial block id - -> ClientM BlockResp -rosettaBlockApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaBlockApiClient_ @v - --- -------------------------------------------------------------------------- -- --- Construction Endpoints - -rosettaConstructionDeriveApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionDeriveReq - -> ClientM ConstructionDeriveResp -rosettaConstructionDeriveApiClient_ = client (rosettaConstructionDeriveApi @v) - -rosettaConstructionDeriveApiClient - :: ChainwebVersion - -> ConstructionDeriveReq - -> ClientM ConstructionDeriveResp -rosettaConstructionDeriveApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionDeriveApiClient_ @v - -rosettaConstructionPreprocessApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionPreprocessReq - -> ClientM ConstructionPreprocessResp -rosettaConstructionPreprocessApiClient_ = client (rosettaConstructionPreprocessApi @v) - -rosettaConstructionPreprocessApiClient - :: ChainwebVersion - -> ConstructionPreprocessReq - -> ClientM ConstructionPreprocessResp -rosettaConstructionPreprocessApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionPreprocessApiClient_ @v - -rosettaConstructionMetadataApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionMetadataReq - -- ^ contains a network id and a metadata object which specifies the - -- metadata to return. - -> ClientM ConstructionMetadataResp -rosettaConstructionMetadataApiClient_ = client (rosettaConstructionMetadataApi @v) - -rosettaConstructionMetadataApiClient - :: ChainwebVersion - -> ConstructionMetadataReq - -- ^ contains a network id and a metadata object which specifies the - -- metadata to return. - -> ClientM ConstructionMetadataResp -rosettaConstructionMetadataApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionMetadataApiClient_ @v - -rosettaConstructionPayloadsApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionPayloadsReq - -> ClientM ConstructionPayloadsResp -rosettaConstructionPayloadsApiClient_ = client (rosettaConstructionPayloadsApi @v) - -rosettaConstructionPayloadsApiClient - :: ChainwebVersion - -> ConstructionPayloadsReq - -> ClientM ConstructionPayloadsResp -rosettaConstructionPayloadsApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionPayloadsApiClient_ @v - -rosettaConstructionParseApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionParseReq - -> ClientM ConstructionParseResp -rosettaConstructionParseApiClient_ = client (rosettaConstructionParseApi @v) - -rosettaConstructionParseApiClient - :: ChainwebVersion - -> ConstructionParseReq - -> ClientM ConstructionParseResp -rosettaConstructionParseApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionParseApiClient_ @v - -rosettaConstructionCombineApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionCombineReq - -> ClientM ConstructionCombineResp -rosettaConstructionCombineApiClient_ = client (rosettaConstructionCombineApi @v) - -rosettaConstructionCombineApiClient - :: ChainwebVersion - -> ConstructionCombineReq - -> ClientM ConstructionCombineResp -rosettaConstructionCombineApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionCombineApiClient_ @v - -rosettaConstructionHashApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionHashReq - -> ClientM TransactionIdResp -rosettaConstructionHashApiClient_ = client (rosettaConstructionHashApi @v) - -rosettaConstructionHashApiClient - :: ChainwebVersion - -> ConstructionHashReq - -> ClientM TransactionIdResp -rosettaConstructionHashApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionHashApiClient_ @v - -rosettaConstructionSubmitApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => ConstructionSubmitReq - -- ^ Contains a network id and a signed transaction - -> ClientM TransactionIdResp -rosettaConstructionSubmitApiClient_ = client (rosettaConstructionSubmitApi @v) - -rosettaConstructionSubmitApiClient - :: ChainwebVersion - -> ConstructionSubmitReq - -- ^ Contains a network id and a signed transaction - -> ClientM TransactionIdResp -rosettaConstructionSubmitApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaConstructionSubmitApiClient_ @v - --- -------------------------------------------------------------------------- -- --- Mempool Endpoints - -rosettaMempoolTransactionApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => MempoolTransactionReq - -- ^ Contains a network id and a transaction id - -> ClientM MempoolTransactionResp -rosettaMempoolTransactionApiClient_ = client (rosettaMempoolTransactionApi @v) - -rosettaMempoolTransactionApiClient - :: ChainwebVersion - -> MempoolTransactionReq - -- ^ Contains a network id and a transaction id - -> ClientM MempoolTransactionResp -rosettaMempoolTransactionApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaMempoolTransactionApiClient_ @v - -rosettaMempoolApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => NetworkReq - -- ^ contains a network id - -> ClientM MempoolResp -rosettaMempoolApiClient_ = client (rosettaMempoolApi @v) - -rosettaMempoolApiClient - :: ChainwebVersion - -> NetworkReq - -- ^ contains a network id - -> ClientM MempoolResp -rosettaMempoolApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaMempoolApiClient_ @v - --- -------------------------------------------------------------------------- -- --- Network Endpoints - -rosettaNetworkListApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => MetadataReq - -- ^ Contains an optional object with metadata - -> ClientM NetworkListResp -rosettaNetworkListApiClient_ = client (rosettaNetworkListApi @v) - -rosettaNetworkListApiClient - :: ChainwebVersion - -> MetadataReq - -- ^ Contains an optional object with metadata - -> ClientM NetworkListResp -rosettaNetworkListApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaNetworkListApiClient_ @v - -rosettaNetworkOptionsApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => NetworkReq - -- ^ Contains a network identifier and optional object with metadata - -> ClientM NetworkOptionsResp -rosettaNetworkOptionsApiClient_ = client (rosettaNetworkOptionsApi @v) - -rosettaNetworkOptionsApiClient - :: ChainwebVersion - -> NetworkReq - -- ^ Contains a network identifier and optional object with metadata - -> ClientM NetworkOptionsResp -rosettaNetworkOptionsApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaNetworkOptionsApiClient_ @v - -rosettaNetworkStatusApiClient_ - :: forall (v :: ChainwebVersionT) - . KnownChainwebVersionSymbol v - => NetworkReq - -- ^ Contains a network identifier and optional object with metadata - -> ClientM NetworkStatusResp -rosettaNetworkStatusApiClient_ = client (rosettaNetworkStatusApi @v) - -rosettaNetworkStatusApiClient - :: ChainwebVersion - -> NetworkReq - -- ^ Contains a network identifier and optional object with metadata - -> ClientM NetworkStatusResp -rosettaNetworkStatusApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = rosettaNetworkStatusApiClient_ @v diff --git a/src/Chainweb/Rosetta/RestAPI/Server.hs b/src/Chainweb/Rosetta/RestAPI/Server.hs deleted file mode 100644 index dfbd9220d5..0000000000 --- a/src/Chainweb/Rosetta/RestAPI/Server.hs +++ /dev/null @@ -1,666 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module: Chainweb.Rosetta.RestAPI.Server --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: MIT --- Maintainer: Colin Woodbury --- Stability: experimental --- --- -module Chainweb.Rosetta.RestAPI.Server -( someRosettaServer -, someRosettaConstructionServer -, someRosettaConstructionDeprecationServer -) where - -import Control.Error.Util -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Data.Aeson -import qualified Data.Aeson.KeyMap as KM -import Data.IORef -import Data.List (sort) -import Data.Proxy (Proxy(..)) - -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import qualified Data.Vector as V - -import qualified Pact.Types.Command as Pact4 -import Pact.Types.Util (fromText') - -import Rosetta - -import Servant.API -import Servant.Server - --- internal modules - -import Chainweb.BlockHeader -import Chainweb.ChainId -import Chainweb.Cut (_cutMap) -import Chainweb.CutDB -import Chainweb.HostAddress -import Chainweb.Mempool.Mempool -import Chainweb.Pact.RestAPI.Server -import Chainweb.Payload.PayloadStore -import qualified Chainweb.RestAPI.NetworkID as ChainwebNetId -import Chainweb.RestAPI.Utils -import Chainweb.Rosetta.Internal -import Chainweb.Rosetta.RestAPI -import Chainweb.Rosetta.Utils -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Utils -import Chainweb.Utils.Paging -import Chainweb.Version -import Chainweb.WebPactExecutionService - -import P2P.Node.PeerDB -import P2P.Node.RestAPI.Server (peerGetHandler) -import P2P.Peer - --- -------------------------------------------------------------------------- -- --- Rosetta Server - -rosettaServer - :: forall tbl (v :: ChainwebVersionT) - . CanReadablePayloadCas tbl - => ChainwebVersion - -> [(ChainId, PayloadDb tbl)] - -> [(ChainId, MempoolBackend Pact4.UnparsedTransaction)] - -> PeerDb - -> CutDb tbl - -> [(ChainId, PactExecutionService)] - -> Server (RosettaApi v) -rosettaServer v ps ms peerDb cutDb pacts = - -- Account -- - accountBalanceH v cutDb pacts - -- Blocks -- - :<|> blockTransactionH v cutDb ps pacts - :<|> blockH v cutDb ps pacts - -- Mempool -- - :<|> mempoolTransactionH v ms - :<|> mempoolH v ms - -- Network -- - :<|> networkListH v cutDb - :<|> networkOptionsH v - :<|> networkStatusH v cutDb peerDb - -someRosettaServer - :: CanReadablePayloadCas tbl - => ChainwebVersion - -> [(ChainId, PayloadDb tbl)] - -> [(ChainId, MempoolBackend Pact4.UnparsedTransaction)] - -> PeerDb - -> [(ChainId, PactExecutionService)] - -> CutDb tbl - -> SomeServer -someRosettaServer v@(FromSingChainwebVersion (SChainwebVersion :: Sing vT)) ps ms pdb pacts cdb = - SomeServer (Proxy @(RosettaApi vT)) $ rosettaServer v ps ms pdb cdb pacts - --- -------------------------------------------------------------------------- -- --- Construction API Server - -rosettaConstructionServer - :: forall tbl (v :: ChainwebVersionT) - . CanReadablePayloadCas tbl - => ChainwebVersion - -> [(ChainId, MempoolBackend Pact4.UnparsedTransaction)] - -> CutDb tbl - -> [(ChainId, PactExecutionService)] - -> Server (RosettaConstructionApi v) -rosettaConstructionServer v ms cutDb pacts = - constructionDeriveH v - :<|> constructionPreprocessH v - :<|> constructionMetadataH v cutDb pacts - :<|> constructionPayloadsH v - :<|> constructionParseH v - :<|> constructionCombineH - :<|> constructionHashH - :<|> constructionSubmitH v ms - - -someRosettaConstructionServer - :: CanReadablePayloadCas tbl - => ChainwebVersion - -> [(ChainId, MempoolBackend Pact4.UnparsedTransaction)] - -> [(ChainId, PactExecutionService)] - -> CutDb tbl - -> SomeServer -someRosettaConstructionServer v@(FromSingChainwebVersion (SChainwebVersion :: Sing vT)) ms pacts cdb = - SomeServer (Proxy @(RosettaConstructionApi vT)) $ rosettaConstructionServer v ms cdb pacts - --- Return a deprecation warning when Rosetta is generally enabled but the --- construction API is disabled. --- -someRosettaConstructionDeprecationServer :: ChainwebVersion -> SomeServer -someRosettaConstructionDeprecationServer (FromSingChainwebVersion (SChainwebVersion :: Sing vT)) = - SomeServer (Proxy @(RosettaConstructionApi vT)) $ - (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - :<|> (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - :<|> (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - :<|> (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - :<|> (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - :<|> (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - :<|> (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - :<|> (\_ -> throwRosettaError $ rosettaError RosettaConstructionApiDeprecated Nothing) - --- -------------------------------------------------------------------------- -- --- Account Handlers - -accountBalanceH - :: ChainwebVersion - -> CutDb tbl - -> [(ChainId, PactExecutionService)] - -> AccountBalanceReq - -> Handler AccountBalanceResp -accountBalanceH _ _ _ (AccountBalanceReq _ (AccountId _ (Just _) _) _) = throwRosetta RosettaSubAcctUnsupported -accountBalanceH v cutDb pacts (AccountBalanceReq net (AccountId acct _ _) pbid) = - runExceptT work >>= either throwRosetta pure - where - acctBalResp bid bal = AccountBalanceResp - { _accountBalanceResp_blockId = bid - , _accountBalanceResp_balances = [ kdaToRosettaAmount bal ] - , _accountBalanceResp_coins = Nothing - , _accountBalanceResp_metadata = Nothing - } - - work :: ExceptT RosettaFailure Handler AccountBalanceResp - work = do - cid <- hoistEither $ validateNetwork v net - pact <- lookup cid pacts ?? RosettaInvalidChain - bh <- findBlockHeaderInCurrFork cutDb cid - (get _partialBlockId_index pbid) (get _partialBlockId_hash pbid) - bal <- getHistoricalLookupBalance pact bh acct - pure $ acctBalResp (blockId bh) bal - where - get _ Nothing = Nothing - get f (Just b) = f b - --------------------------------------------------------------------------------- --- Block Handlers - -blockH - :: forall tbl - . CanReadablePayloadCas tbl - => ChainwebVersion - -> CutDb tbl - -> [(ChainId, PayloadDb tbl)] - -> [(ChainId, PactExecutionService)] - -> BlockReq - -> Handler BlockResp -blockH v cutDb ps pacts (BlockReq net (PartialBlockId bheight bhash)) = - runExceptT work >>= either throwRosetta pure - where - block :: BlockHeader -> [Transaction] -> Block - block bh txs = Block - { _block_blockId = blockId bh - , _block_parentBlockId = parentBlockId bh - , _block_timestamp = rosettaTimestamp bh - , _block_transactions = txs - , _block_metadata = Nothing - } - - work :: ExceptT RosettaFailure Handler BlockResp - work = do - cid <- hoistEither $ validateNetwork v net - pact <- lookup cid pacts ?? RosettaInvalidChain - payloadDb <- lookup cid ps ?? RosettaInvalidChain - bh <- findBlockHeaderInCurrFork cutDb cid bheight bhash - (coinbase, txs) <- getBlockOutputs payloadDb bh - logs <- getTxLogs pact bh - trans <- matchLogs FullLogs bh logs coinbase txs - pure $ BlockResp - { _blockResp_block = Just $ block bh trans - , _blockResp_otherTransactions = Nothing - } - -blockTransactionH - :: forall tbl - . CanReadablePayloadCas tbl - => ChainwebVersion - -> CutDb tbl - -> [(ChainId, PayloadDb tbl)] - -> [(ChainId, PactExecutionService)] - -> BlockTransactionReq - -> Handler BlockTransactionResp -blockTransactionH v cutDb ps pacts (BlockTransactionReq net bid t) = - runExceptT work >>= either throwRosetta pure - where - BlockId bheight bhash = bid - TransactionId rtid = t - - work :: ExceptT RosettaFailure Handler BlockTransactionResp - work = do - cid <- hoistEither $ validateNetwork v net - pact <- lookup cid pacts ?? RosettaInvalidChain - payloadDb <- lookup cid ps ?? RosettaInvalidChain - bh <- findBlockHeaderInCurrFork cutDb cid (Just bheight) (Just bhash) - rkTarget <- hush (fromText' rtid) ?? RosettaUnparsableTransactionId - (coinbase, txs) <- getBlockOutputs payloadDb bh - logs <- getTxLogs pact bh - tran <- matchLogs (SingleLog rkTarget) bh logs coinbase txs - - pure $ BlockTransactionResp tran - - --------------------------------------------------------------------------------- --- Construction Handlers --- NOTE: all Construction API endpoints except /metadata and /submit must --- operate in "offline" mode. - --- | Given an ED25519 Public Key, returns the k: account name associated with it. -constructionDeriveH - :: ChainwebVersion - -> ConstructionDeriveReq - -> Handler ConstructionDeriveResp -constructionDeriveH v req = - either throwRosettaError pure work - where - ConstructionDeriveReq net rosettaPubKey _ = req - - work :: Either RosettaError ConstructionDeriveResp - work = do - _ <- annotate rosettaError' (validateNetwork v net) - T2 kAccount ownership <- rosettaPubKeyTokAccount rosettaPubKey - pure $! ConstructionDeriveResp - { _constructionDeriveResp_address = Nothing - , _constructionDeriveResp_accountIdentifier = Just $! accountId kAccount - , _constructionDeriveResp_metadata = Just $! toObject $! DeriveRespMetaData - { _deriveRespMetaData_ownership = ownership } - } - -constructionPreprocessH - :: ChainwebVersion - -> ConstructionPreprocessReq - -> Handler ConstructionPreprocessResp -constructionPreprocessH v req = - either throwRosettaError pure work - where - ConstructionPreprocessReq net ops someMeta someMaxFee someMult = req - - work :: Either RosettaError ConstructionPreprocessResp - work = do - _ <- annotate rosettaError' (validateNetwork v net) - meta <- note (rosettaError' RosettaMissingMetaData) someMeta - parsedMeta :: PreprocessReqMetaData <- extractMetaData meta - - let PreprocessReqMetaData gasPayer _ = parsedMeta - - -- Maps the intended operations to an intermediary dats type - -- that will facilitate creating pact code later on in the workflow. - tx <- opsToConstructionTx ops - - -- The suggested cost of the transaction - (gasLimit, gasPrice, fee) <- getSuggestedFee tx someMaxFee someMult - - -- The accounts that need to sign the transaction - let expectedAccts = neededAccounts tx gasPayer - - pure $! ConstructionPreprocessResp - { _constructionPreprocessResp_options = Just $! toObject $! PreprocessRespMetaData - { _preprocessRespMetaData_reqMetaData = parsedMeta - , _preprocessRespMetaData_tx = tx - , _preprocessRespMetaData_suggestedFee = fee - , _preprocessRespMetaData_gasLimit = gasLimit - , _preprocessRespMetaData_gasPrice = gasPrice - } - , _constructionPreprocessResp_requiredPublicKeys = Just $! expectedAccts - } - - -constructionMetadataH - :: ChainwebVersion - -> CutDb tbl - -> [(ChainId, PactExecutionService)] - -> ConstructionMetadataReq - -> Handler ConstructionMetadataResp -constructionMetadataH v cutDb pacts (ConstructionMetadataReq net opts someKeys) = - runExceptT work >>= either throwRosettaError pure - where - - work :: ExceptT RosettaError Handler ConstructionMetadataResp - work = do - cid <- hoistEither $ annotate rosettaError' (validateNetwork v net) - availableSigners <- someKeys ?? rosettaError' RosettaMissingPublicKeys - >>= hoistEither . rosettaPubKeysToSignerMap - meta :: PreprocessRespMetaData <- hoistEither $ extractMetaData opts - let PreprocessRespMetaData reqMeta tx fee gLimit gPrice = meta - PreprocessReqMetaData payer someNonce = reqMeta - - pubMeta <- liftIO $ toPublicMeta cid payer gLimit gPrice - let nonce = toNonce someNonce pubMeta - - expectedAccts <- toSignerAcctsMap tx payer cid pacts cutDb - signersAndAccts <- hoistEither $! - createSigners availableSigners expectedAccts - - pure $! ConstructionMetadataResp - { _constructionMetadataResp_metadata = toObject $! PayloadsMetaData - { _payloadsMetaData_signers = signersAndAccts - , _payloadsMetaData_nonce = nonce - , _payloadsMetaData_publicMeta = pubMeta - , _payloadsMetaData_tx = tx - } - , _constructionMetadataResp_suggestedFee = Just [fee] - } - - -constructionPayloadsH - :: ChainwebVersion - -> ConstructionPayloadsReq - -> Handler ConstructionPayloadsResp -constructionPayloadsH v req = - runExceptT work >>= either throwRosettaError pure - where - (ConstructionPayloadsReq net _ someMeta _) = req - - work :: ExceptT RosettaError Handler ConstructionPayloadsResp - work = do - void $ hoistEither $ annotate rosettaError' (validateNetwork v net) - meta :: PayloadsMetaData <- hoistEither $ note - (rosettaError' RosettaMissingMetaData) someMeta >>= - extractMetaData - unsigned :: EnrichedCommand <- liftIO $ createUnsignedCmd v meta - let encoded = enrichedCommandToText $! unsigned - signingPayloads = createSigningPayloads unsigned - (_payloadsMetaData_signers meta) - - pure $ ConstructionPayloadsResp - { _constructionPayloadsResp_unsignedTransaction = encoded - , _constructionPayloadsResp_payloads = signingPayloads - } - - -constructionParseH - :: ChainwebVersion - -> ConstructionParseReq - -> Handler ConstructionParseResp -constructionParseH v (ConstructionParseReq net isSigned tx) = - either throwRosettaError pure work - where - work :: Either RosettaError ConstructionParseResp - work = do - cid <- annotate rosettaError' (validateNetwork v net) - - (EnrichedCommand cmd txInfo signAccts) <- note - (rosettaError' RosettaUnparsableTx) - $ textToEnrichedCommand tx - signers <- getRosettaSigners cid cmd signAccts - let ops = txToOps txInfo - - pure $ ConstructionParseResp - { _constructionParseResp_operations = ops - , _constructionParseResp_signers = Nothing - , _constructionParseResp_accountIdentifierSigners = Just signers - , _constructionParseResp_metadata = Nothing - } - - getRosettaSigners cid cmd expectedSignerAccts - | isSigned = do - _ <- toRosettaError RosettaInvalidTx $ validateCommand v cid cmd - pure expectedSignerAccts - -- If transaction signatures successfully validates, - -- it was signed correctly with all of the account public - -- keys needed. - -- NOTE: Might contain repetitions. - | otherwise = pure [] - - -constructionCombineH - :: ConstructionCombineReq - -> Handler ConstructionCombineResp -constructionCombineH (ConstructionCombineReq _ unsignedTx sigs) = - either throwRosettaError pure work - where - work :: Either RosettaError ConstructionCombineResp - work = do - (EnrichedCommand unsignedCmd meta signAccts) <- note - (rosettaError' RosettaUnparsableTx) - $ textToEnrichedCommand unsignedTx - payload <- getCmdPayload unsignedCmd - userSigs <- matchSigs sigs (Pact4._pSigners $! payload) - - let signedCmd = unsignedCmd { Pact4._cmdSigs = userSigs } - signedTx = enrichedCommandToText (EnrichedCommand signedCmd meta signAccts) - pure $ ConstructionCombineResp signedTx - - -constructionHashH - :: ConstructionHashReq - -> Handler TransactionIdResp -constructionHashH (ConstructionHashReq _ signedTx) = - either throwRosetta pure work - where - work :: Either RosettaFailure TransactionIdResp - work = do - (EnrichedCommand cmd _ _) <- note RosettaUnparsableTx - $ textToEnrichedCommand signedTx - pure $ TransactionIdResp (cmdToTransactionId cmd) Nothing - - --- Note (linda): This code simulates the logic of `sendHandler` closely. -constructionSubmitH - :: ChainwebVersion - -> [(ChainId, MempoolBackend Pact4.UnparsedTransaction)] - -> ConstructionSubmitReq - -> Handler TransactionIdResp -constructionSubmitH v ms (ConstructionSubmitReq net tx) = - runExceptT work >>= either throwRosettaError pure - where - checkResult - :: Either (T2 TransactionHash InsertError) () - -> ExceptT RosettaError Handler () - checkResult (Right _) = pure () - checkResult (Left (T2 hsh insErr)) = - throwE $ stringRosettaError RosettaInvalidTx - $ "Validation failed for hash " - ++ (show $! hsh) ++ ": " - ++ show insErr - - work :: ExceptT RosettaError Handler TransactionIdResp - work = do - cid <- hoistEither $ annotate rosettaError' (validateNetwork v net) - mempool <- hoistEither $ - note (rosettaError' RosettaInvalidChain) - $ lookup cid ms - (EnrichedCommand cmd _ _) <- hoistEither $ - note (rosettaError' RosettaUnparsableTx) - $ textToEnrichedCommand tx - - -- TODO: pact5... what do we do here? - case validateCommand v cid cmd of - Right validated -> do - let txs = (fmap . fmap . fmap) Pact4._pcCode $ - V.fromList [validated] - -- If any of the txs in the batch fail validation, we reject them all. - liftIO (mempoolInsertCheck mempool txs) >>= checkResult - liftIO (mempoolInsert mempool UncheckedInsert txs) - pure $ TransactionIdResp (cmdToTransactionId cmd) Nothing - Left e -> throwE $ stringRosettaError RosettaInvalidTx - $ "Validation failed: " ++ show e - --------------------------------------------------------------------------------- --- Mempool Handlers - -mempoolH - :: ChainwebVersion - -> [(ChainId, MempoolBackend a)] - -> NetworkReq - -> Handler MempoolResp -mempoolH v ms (NetworkReq net _) = work >>= \case - Left !e -> throwRosetta e - Right !a -> pure a - where - f :: TransactionHash -> TransactionId - f !h = TransactionId $ toText h - - work = runExceptT $! do - cid <- hoistEither $ validateNetwork v net - mp <- lookup cid ms ?? RosettaInvalidChain - r <- liftIO $ newIORef mempty - -- TODO: This will need to be revisited once we can add - -- pagination + streaming the mempool - void $! liftIO $ mempoolGetPendingTransactions mp Nothing $ \hs -> do - modifyIORef' r (<> hs) - - txs <- liftIO $! readIORef r - let !ts = V.toList $ f <$!> txs - return $ MempoolResp ts - -mempoolTransactionH - :: ChainwebVersion - -> [(ChainId, MempoolBackend a)] - -> MempoolTransactionReq - -> Handler MempoolTransactionResp -mempoolTransactionH v ms mtr = runExceptT work >>= either throwRosetta pure - where - MempoolTransactionReq net (TransactionId ti) = mtr - - f :: LookupResult a -> Maybe MempoolTransactionResp - f Missing = Nothing - f (Pending _) = Just $ MempoolTransactionResp tx Nothing - where - tx = Transaction - { _transaction_transactionId = TransactionId ti - , _transaction_operations = [] -- Can't even know who will pay for gas at this moment - , _transaction_metadata = Nothing - } - - work :: ExceptT RosettaFailure Handler MempoolTransactionResp - work = do - cid <- hoistEither $ validateNetwork v net - mp <- lookup cid ms ?? RosettaInvalidChain - th <- hush (fromText ti) ?? RosettaUnparsableTransactionId - lrs <- liftIO . mempoolLookup mp $ V.singleton th - (lrs V.!? 0 >>= f) ?? RosettaMempoolBadTx - --------------------------------------------------------------------------------- --- Network Handlers - -networkListH :: ChainwebVersion -> CutDb tbl -> MetadataReq -> Handler NetworkListResp -networkListH v cutDb _ = runExceptT work >>= either throwRosetta pure - where - work = do - c <- liftIO $ _cut cutDb - - -- Unique Rosetta network ids for each of the Chainweb Version's chain ids at - -- the current cut. - -- NOTE: This ensures only returning chains that are "active" at - -- the current time. - let networkIds = map f $! sort $! HM.keys (_cutMap c) - pure $ NetworkListResp networkIds - - f :: ChainId -> NetworkId - f cid = NetworkId - { _networkId_blockchain = "kadena" - , _networkId_network = getChainwebVersionName $ _versionName v - , _networkId_subNetworkId = Just (SubNetworkId (chainIdToText cid) Nothing) - } - -networkOptionsH :: ChainwebVersion -> NetworkReq -> Handler NetworkOptionsResp -networkOptionsH v (NetworkReq nid _) = runExceptT work >>= either throwRosetta pure - where - work :: ExceptT RosettaFailure Handler NetworkOptionsResp - work = do - void $ hoistEither $ validateNetwork v nid - pure $ NetworkOptionsResp version allow - - version = RosettaNodeVersion - { _version_rosettaVersion = rosettaSpecVersion - , _version_nodeVersion = chainwebNodeVersionHeaderValue - , _version_middlewareVersion = Nothing - , _version_metadata = Just $ KM.fromList metaPairs } - - -- TODO: Document this meta data - metaPairs = - [ "node-api-version" .= prettyApiVersion - , "chainweb-version" .= getChainwebVersionName (_versionName v) - , "rosetta-chainweb-version" .= rosettaImplementationVersion - -- The version of the rosetta implementation. - -- Meant to capture if something about the internal - -- implementation has changed. - ] - - rosettaImplementationVersion = "2.0.0" :: T.Text - - allow = Allow - { _allow_operationStatuses = opStatuses - , _allow_operationTypes = opTypes - , _allow_errors = errExamples - , _allow_historicalBalanceLookup = True } - - errExamples :: [RosettaError] - errExamples = map (`rosettaError` Nothing) [minBound .. maxBound] - - opStatuses :: [OperationStatus] - opStatuses = map operationStatus [minBound .. maxBound] - - opTypes :: [T.Text] - opTypes = map sshow ([minBound .. maxBound] :: [OperationType]) - -networkStatusH - :: ChainwebVersion - -> CutDb tbl - -> PeerDb - -> NetworkReq - -> Handler NetworkStatusResp -networkStatusH v cutDb peerDb (NetworkReq nid _) = - runExceptT work >>= either throwRosetta pure - where - work :: ExceptT RosettaFailure Handler NetworkStatusResp - work = do - cid <- hoistEither $ validateNetwork v nid - bh <- getLatestBlockHeader cutDb cid - let genesisBh = genesisBlockHeader v cid - peers <- lift $ _pageItems <$> - peerGetHandler - peerDb - ChainwebNetId.CutNetwork - -- TODO: document max number of peers returned - (Just $ Limit maxRosettaNodePeerLimit) - Nothing - pure $ resp bh genesisBh peers - - resp :: BlockHeader -> BlockHeader -> [PeerInfo] -> NetworkStatusResp - resp bh genesis ps = NetworkStatusResp - { _networkStatusResp_currentBlockId = blockId bh - , _networkStatusResp_currentBlockTimestamp = rosettaTimestamp bh - , _networkStatusResp_genesisBlockId = blockId genesis - , _networkStatusResp_oldestBlockIdentifier = Nothing - , _networkStatusResp_syncStatus = Nothing - , _networkStatusResp_peers = rosettaNodePeers ps - } - - rosettaNodePeers :: [PeerInfo] -> [RosettaNodePeer] - rosettaNodePeers = map f - where - f :: PeerInfo -> RosettaNodePeer - f p = RosettaNodePeer - { _peer_peerId = hostAddressToText $ _peerAddr p - , _peer_metadata = Just . KM.fromList $ metaPairs p } - - -- TODO: document this meta data - metaPairs :: PeerInfo -> [(Key, Value)] - metaPairs p = addrPairs (_peerAddr p) ++ someCertPair (_peerId p) - - addrPairs :: HostAddress -> [(Key, Value)] - addrPairs addr = - [ "address_hostname" .= hostnameToText (_hostAddressHost addr) - , "address_port" .= portToText (_hostAddressPort addr) - -- TODO: document that port is string represation of Word16 - ] - - someCertPair :: Maybe PeerId -> [(Key, Value)] - someCertPair (Just i) = ["certificate_id" .= i] - someCertPair Nothing = [] diff --git a/src/Chainweb/Rosetta/Utils.hs b/src/Chainweb/Rosetta/Utils.hs deleted file mode 100644 index eae6551f2e..0000000000 --- a/src/Chainweb/Rosetta/Utils.hs +++ /dev/null @@ -1,1271 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module: Chainweb.Rosetta.Utils --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: MIT --- Maintainer: Linda Ortega --- Stability: experimental --- --- -module Chainweb.Rosetta.Utils where - -import Control.Monad (when) -import Control.Error.Util -import Control.Lens (view) -import Data.Aeson -import Data.Aeson.Types (Pair) -import qualified Data.Aeson.KeyMap as KM -import Data.Bifunctor (first) -#if !MIN_VERSION_base(4,20,0) -import Data.Foldable (foldl') -#endif -import Data.Decimal ( Decimal, DecimalRaw(Decimal) ) -import Data.Hashable (Hashable(..)) -import Data.List (sortOn, inits) -import Data.Word (Word32, Word64) -import Text.Read (readMaybe) -import Text.Printf ( printf ) - -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Short as BS -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as M -import qualified Data.Memory.Endian as BA -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Pact.Types.Runtime as P -import qualified Pact.Types.RPC as P -import qualified Pact.Types.Command as P -import qualified Pact.Parse as P -import qualified Pact.JSON.Decode as J -import qualified Data.Set as S -import Data.Maybe (fromMaybe) - -import Numeric.Natural ( Natural ) - -import Pact.Types.Command -import Pact.Types.PactValue (PactValue(..)) -import Pact.JSON.Legacy.Value - -import qualified Pact.Core.Persistence as PCore -import qualified Pact.Core.PactValue as PCore -import qualified Pact.Core.Literal as PCore -import qualified Pact.Core.Names as PCore -import qualified Pact.Core.StableEncoding as PCore - -import Rosetta - --- internal modules - -import Chainweb.BlockCreationTime (BlockCreationTime(..)) -import Chainweb.BlockHash ( blockHashToText ) -import Chainweb.BlockHeader -import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.ChainId -import Chainweb.Pact.Utils -import Chainweb.Time -import Chainweb.Utils ( sshow, int, T2(..) ) -import Chainweb.Version - ---- - - --------------------------------------------------------------------------------- --- Rosetta Metadata Types -- --------------------------------------------------------------------------------- - --- | Helper typeclass for transforming Rosetta metadata into a --- JSON Object. --- NOTE: Rosetta types expect metadata to be `Object` -class ToObject a where - toPairs :: a -> [(Key, Value)] - toObject :: a -> Object - - -data OperationMetaData = OperationMetaData - { _operationMetaData_prevOwnership :: !Value - , _operationMetaData_currOwnership :: !Value --TODO: hack for rotation bug - } deriving Show --- TODO: document -instance ToObject OperationMetaData where - toPairs (OperationMetaData prevOwnership currOwnership) = - [ "prev-ownership" .= prevOwnership - , "curr-ownership" .= currOwnership ] - toObject opMeta = KM.fromList (toPairs opMeta) -instance FromJSON OperationMetaData where - parseJSON = withObject "OperationMetaData" $ \o -> do - prevOwnership <- o .: "prev-ownership" - currOwnership <- o .: "curr-ownership" - pure OperationMetaData - { _operationMetaData_prevOwnership = prevOwnership - , _operationMetaData_currOwnership = currOwnership - } - --- TODO: Not currently used because of ownership rotation bug. -newtype AccountIdMetaData = AccountIdMetaData - { _accountIdMetaData_currOwnership :: Value } - deriving Show -instance ToObject AccountIdMetaData where - toPairs (AccountIdMetaData currOwnership) = - [ "current-ownership" .= currOwnership ] - toObject acctMeta = KM.fromList (toPairs acctMeta) -instance FromJSON AccountIdMetaData where - parseJSON = withObject "AccountIdMetaData" $ \o -> do - currOwnership <- o .: "current-ownership" - pure AccountIdMetaData { - _accountIdMetaData_currOwnership = currOwnership - } - -newtype TransactionMetaData = TransactionMetaData - { _transactionMetaData_multiStepTx :: Maybe ContinuationMetaData - } -instance ToObject TransactionMetaData where - toPairs (TransactionMetaData Nothing) = [] - toPairs (TransactionMetaData (Just multi)) = - [ "multi-step-transaction" .= toObject multi ] - toObject txMeta = KM.fromList (toPairs txMeta) - -transactionMetaData :: ChainId -> CommandResult a -> TransactionMetaData -transactionMetaData cid cr = case _crContinuation cr of - Nothing -> TransactionMetaData Nothing - Just pe -> TransactionMetaData $ Just (toContMeta cid pe) - - --- | Adds more transparency into a continuation transaction --- that was just executed. -data ContinuationMetaData = ContinuationMetaData - { _continuationMetaData_currStep :: !ContinuationCurrStep - -- ^ Information on the current step in the continuation. - , _continuationStep_nextStep :: !(Maybe ContinuationNextStep) - -- ^ Information on the next step in the continuation (if there is one). - , _continuationMetaData_pactIdReqKey :: !P.PactId - -- ^ The request key of the transaction that initiated this continuation. - -- TODO: Further work needs to be done to know WHICH chain this - -- initial transaction occurred in. - , _continuationMetaData_totalSteps :: !Int - -- ^ Total number of steps in the entire continuation. - } deriving Show --- TODO: document -instance ToObject ContinuationMetaData where - toPairs (ContinuationMetaData curr next rk total) = - [ "current-step" .= toObject curr - , "first-step-request-key" .= toLegacyJsonViaEncode rk - , "total-steps" .= total ] - <> omitNextIfMissing - where - omitNextIfMissing = case next of - Nothing -> [] - Just ns -> [ "next-step" .= toObject ns ] - toObject contMeta = KM.fromList (toPairs contMeta) - -toContMeta :: ChainId -> P.PactExec -> ContinuationMetaData -toContMeta cid pe = ContinuationMetaData - { _continuationMetaData_currStep = toContStep cid pe - , _continuationStep_nextStep = toContNextStep cid pe - , _continuationMetaData_pactIdReqKey = P._pePactId pe - , _continuationMetaData_totalSteps = P._peStepCount pe - } - - --- | Provides information on the continuation step that was just executed. -data ContinuationCurrStep = ContinuationCurrStep - { _continuationCurrStep_chainId :: !T.Text - -- ^ Chain id where step was executed - , _continuationCurrStep_stepId :: !Int - -- ^ Step that was executed or skipped - , _continuationCurrStep_rollbackAvailable :: Bool - -- ^ Track whether a current step allows for rollbacks - } deriving Show --- TODO: Add ability to detect if step was rolled back. --- TODO: document -instance ToObject ContinuationCurrStep where - toPairs (ContinuationCurrStep cid step rollback) = - [ "chain-id" .= cid - , "step-id" .= step - , "rollback-available" .= rollback ] - toObject contCurrStep = KM.fromList (toPairs contCurrStep) - -toContStep :: ChainId -> P.PactExec -> ContinuationCurrStep -toContStep cid pe = ContinuationCurrStep - { _continuationCurrStep_chainId = chainIdToText cid - , _continuationCurrStep_stepId = P._peStep pe - , _continuationCurrStep_rollbackAvailable = P._peStepHasRollback pe - } - - --- | Indicates if the next step of a continuation occurs in a --- different chain or in the same chain. -newtype ContinuationNextStep = ContinuationNextStep - { _continuationNextStep_chainId :: T.Text - } deriving Show --- TODO: document -instance ToObject ContinuationNextStep where - toPairs (ContinuationNextStep cid) = [ "target-chain-id" .= cid ] - toObject contNextStep = KM.fromList (toPairs contNextStep) - --- | Determines if the continuation has a next step and, if so, provides --- the chain id of where this next step will need to occur. -toContNextStep - :: ChainId - -> P.PactExec - -> Maybe ContinuationNextStep -toContNextStep currChainId pe - | isLastStep = Nothing - -- TODO: Add check to see if curr step was rolled back. - -- This would also mean a next step is not occuring. - | otherwise = case P._peYield pe >>= P._yProvenance of - Nothing -> Just $ ContinuationNextStep $ chainIdToText currChainId - -- next step occurs in the same chain - Just (P.Provenance nextChainId _) -> - -- next step is a cross-chain step - Just $ ContinuationNextStep (P._chainId nextChainId) - where - isLastStep = succ $ P._peStep pe == P._peStepCount pe - --------------------------------------------------------------------------------- --- Rosetta ConstructionAPI Types and Helper Functions -- --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- /preprocess -data PreprocessReqMetaData = PreprocessReqMetaData - { _preprocessReqMetaData_gasPayer :: !AccountId - , _preprocessReqMetaData_nonce :: !(Maybe T.Text) - } deriving (Show, Eq) -instance ToObject PreprocessReqMetaData where - toPairs (PreprocessReqMetaData payer someNonce) = - toPairOmitMaybe - [ "gas_payer" .= payer ] - [ maybePair "nonce" someNonce ] - toObject meta = KM.fromList (toPairs meta) -instance ToJSON PreprocessReqMetaData where - toJSON = object . toPairs -instance FromJSON PreprocessReqMetaData where - parseJSON = withObject "PreprocessReqMetaData" $ \o -> do - payer <- o .: "gas_payer" - nonce <- o .:? "nonce" - _ <- case rosettaAccountIdtoKAccount payer of - Left errMsg -> error $ show errMsg - Right _ -> pure () - return $ PreprocessReqMetaData - { _preprocessReqMetaData_gasPayer = payer - , _preprocessReqMetaData_nonce = nonce - } - - --- | The different types of pact coin-contract transactions allowed in --- Construction API. Used in the response of both /preprocess and /metadata endpoints. --- NOTE: Only KeySet guards are considered for simplicity. -data ConstructionTx = - ConstructTransfer - { _constructTransfer_from :: !AccountId - , _constructTransfer_fromGuard :: !P.KeySet - , _constructTransfer_to :: !AccountId - , _constructTransfer_toGuard :: !P.KeySet - , _constructTransfer_amount :: !P.ParsedDecimal - } - deriving (Show, Eq) -instance ToJSON ConstructionTx where - toJSON (ConstructTransfer from fromGuard to toGuard amt) = - object [ "tx_type" .= ("transfer" :: T.Text) - , "sender_account" .= from - , "sender_ownership" .= toLegacyJsonViaEncode fromGuard - , "receiver_account" .= to - , "receiver_ownership" .= toLegacyJsonViaEncode toGuard - , "transfer_amount" .= toLegacyJsonViaEncode amt ] -instance FromJSON ConstructionTx where - parseJSON = withObject "ConstructionTx" $ \o -> do - typ :: T.Text <- o .: "tx_type" - case typ of - "transfer" -> parseTransfer o - _ -> error $ "Invalid ConstructionTx 'tx_type' value: " ++ show typ - where - parseTransfer o = do - from <- o .: "sender_account" - fromGuard <- o .: "sender_ownership" - to <- o .: "receiver_account" - toGuard <- o .: "receiver_ownership" - amt <- o .: "transfer_amount" - let actualTx = ConstructTransfer - { _constructTransfer_from = from - , _constructTransfer_fromGuard = fromGuard - , _constructTransfer_to = to - , _constructTransfer_toGuard = toGuard - , _constructTransfer_amount = amt - } - from' = (from, negate amt, fromGuard) - to' = (to, amt, toGuard) - case transferTx from' to' of - Left errMsg -> error $ show errMsg - Right expectedTx - | expectedTx == actualTx -> pure actualTx - | otherwise -> error $ - "Expected ConstructionTx: " <> show expectedTx <> - "/n but received: " <> show actualTx - --- Constructs a Transfer ConstructionTx and --- performs balance and k:account checks. -transferTx - :: (AccountId, P.ParsedDecimal, P.KeySet) - -> (AccountId, P.ParsedDecimal, P.KeySet) - -> Either RosettaError ConstructionTx -transferTx (acct1, bal1, ks1) (acct2, bal2, ks2) - | acct1 == acct2 = - rerr RosettaInvalidOperations - "Cannot transfer to the same account name" - -- Enforce accounts are valid k accounts - | not (validateKAccount $ _accountId_address acct1) = - rerr RosettaInvalidKAccount - (show acct1) - | not (validateKAccount $ _accountId_address acct2) = - rerr RosettaInvalidKAccount - (show acct2) - | not (validateKAccountKeySet (_accountId_address acct1) ks1) = - rerr RosettaInvalidKAccount $ - "Invalid KeySet: " <> show ks1 - | not (validateKAccountKeySet (_accountId_address acct2) ks2) = - rerr RosettaInvalidKAccount $ - "Invalid KeySet: " <> show ks2 - -- Perform balance checks - | bal1 + bal2 /= 0.0 = - rerr RosettaInvalidOperations - "transfer amounts: Mass conversation not preserved" - | bal1 == 0 || bal2 == 0 = - rerr RosettaInvalidOperations - "transfer amounts: Cannot transfer zero amounts" - | bal1 < 0.0 = pure $ ConstructTransfer - { _constructTransfer_from = acct1 -- bal1 is negative, so acct1 is debitor (from) - , _constructTransfer_fromGuard = ks1 - , _constructTransfer_to = acct2 -- bal2 is positive, so acct2 is creditor (to) - , _constructTransfer_toGuard = ks2 - , _constructTransfer_amount = abs bal1 - } - | otherwise = pure $ ConstructTransfer - { _constructTransfer_from = acct2 -- bal2 is negative, so acct2 is debitor (from) - , _constructTransfer_fromGuard = ks2 - , _constructTransfer_to = acct1 -- bal1 is positive, so acct1 is creditor (to) - , _constructTransfer_toGuard = ks1 - , _constructTransfer_amount = abs bal1 - } - where - rerr f msg = Left $ stringRosettaError f msg - -newtype DeriveRespMetaData = DeriveRespMetaData - { _deriveRespMetaData_ownership :: P.KeySet } -instance ToObject DeriveRespMetaData where - toPairs (DeriveRespMetaData ownership) = - [ "ownership" .= toLegacyJsonViaEncode ownership ] - toObject m = KM.fromList (toPairs m) -instance FromJSON DeriveRespMetaData where - parseJSON = withObject "DeriveRespMetaData" $ \o -> do - ownership <- o .: "ownership" - return DeriveRespMetaData - { _deriveRespMetaData_ownership = ownership } - -data PreprocessRespMetaData = PreprocessRespMetaData - { _preprocessRespMetaData_reqMetaData :: PreprocessReqMetaData - , _preprocessRespMetaData_tx :: ConstructionTx - , _preprocessRespMetaData_suggestedFee :: Amount - , _preprocessRespMetaData_gasLimit :: P.GasLimit - , _preprocessRespMetaData_gasPrice :: P.GasPrice - } deriving (Show, Eq) -instance ToObject PreprocessRespMetaData where - toPairs (PreprocessRespMetaData reqMeta txInfo fee gasLimit gasPrice) = - [ "preprocess_request_metadata" .= reqMeta - , "tx_info" .= txInfo - , "suggested_fee" .= fee - , "gas_limit" .= toLegacyJsonViaEncode gasLimit - , "gas_price" .= toLegacyJsonViaEncode gasPrice ] - toObject m = KM.fromList (toPairs m) -instance FromJSON PreprocessRespMetaData where - parseJSON = withObject "PreprocessRespMetaData" $ \o -> do - reqMeta <- o .: "preprocess_request_metadata" - txInfo <- o .: "tx_info" - fee <- o .: "suggested_fee" - gasLimit <- o .: "gas_limit" - gasPrice <- o .: "gas_price" - return PreprocessRespMetaData - { _preprocessRespMetaData_reqMetaData = reqMeta - , _preprocessRespMetaData_tx = txInfo - , _preprocessRespMetaData_suggestedFee = fee - , _preprocessRespMetaData_gasLimit = gasLimit - , _preprocessRespMetaData_gasPrice = gasPrice - } - - --- | Parse list of Operations into feasible Pact transactions. --- NOTE: Expects that user-provided values are valid (i.e. AccountIds). -opsToConstructionTx - :: [Operation] - -> Either RosettaError ConstructionTx -opsToConstructionTx ops = do - ops' <- mapM parseOp ops - case ops' of - [] -> rerr RosettaInvalidOperations - "Found empty list of Operations" - [op1, op2] -> transferTx op1 op2 - _ -> rerr RosettaInvalidOperations - "Expected at MOST two operations" - where - rerr f msg = Left $ stringRosettaError f msg - --- | Calculate the suggested fee in KDA for the transaction to be performed. --- Some optional parameters might be specified, i.e. a max KDA fee and a fee multiplier. --- FORMULA: fee = gasLimit * (gasPrice * multiplier) --- NOTE: The multiplier will be absorbed into the gasPrice since assuming that --- the higher the gasPrice the more likely the transaction will be added to a block. --- Specifications: https://www.rosetta-api.org/docs/1.4.4/models/ConstructionPreprocessRequest.html -getSuggestedFee - :: ConstructionTx - -> Maybe [Amount] - -> Maybe Double - -> Either RosettaError (P.GasLimit, P.GasPrice, Amount) -getSuggestedFee tx someMaxFees someMult = do - someMaxFee <- parseMaxFees someMaxFees - mapM_ checkMaxFeeSufficient someMaxFee - let gasLimit = estimatedGasLimit - someMaxPrice = fmap (calcMaxGasPrice gasLimit) someMaxFee - gasPrice = calcGasPrice someMaxPrice - fee = kdaToRosettaAmount $! calcKDAFee gasLimit gasPrice - - pure (gasLimit, gasPrice, fee) - - where - ------------ - -- Defaults - ------------ - -- NOTE: GasLimit should never be greater than default block gas limit. - - -- Derived from a couple of gas unit cost of the following transfer transactions + some buffer: - -- - https://explorer.chainweb.com/mainnet/txdetail/EUiZfeHHeisKMP2uHpzyAcMOIqZJVsJB6sT_ABpBUsQ - -- - https://explorer.chainweb.com/mainnet/txdetail/-cb0Pz6rKb1NVhAFQ_Bcz2V2dGPjTmIiVBl-gXMLGRQ - -- - https://explorer.chainweb.com/mainnet/txdetail/2riuW2nBmbN2dzmyAh5b2lUns5SPARb44-QN_EKzzmk - defGasUnitsTransferCreate = 4000 - - -- See Chainweb.Chainweb.Configuration for latest min gas - minGasPrice = Decimal 8 1 - - ------------------- - -- Helper Functions - ------------------- - -- Assumption: Currency is in KDA - parseMaxFees :: Maybe [Amount] -> Either RosettaError (Maybe Decimal) - parseMaxFees Nothing = pure Nothing - parseMaxFees (Just []) = pure Nothing - parseMaxFees (Just [a]) = do - dec <- parseAmount a - checkIfPositive dec - pure $ Just dec - where - checkIfPositive d - | d >= 0 = pure () - | otherwise = - Left $ stringRosettaError RosettaInvalidAmount - "max_fee: Expected positive Amount" - parseMaxFees _ = - Left $ stringRosettaError RosettaInvalidAmount - "max_fee: Expected single Amount, but found multiple Amounts." - - -- Make sure that the max fee is sufficent to cover the cost of - -- the specified transaction at the minimum gas price. - checkMaxFeeSufficient :: Decimal -> Either RosettaError () - checkMaxFeeSufficient maxFee - | maxFee >= minFeeNeeded = pure () - | otherwise = - Left $ stringRosettaError RosettaInvalidAmount $ - "max_fee: Expected a minimum fee of " ++ show minFeeNeeded ++ - "KDA for specified operations, but received max_fee=" ++ show maxFee ++ "KDA" - where - minFeeNeeded = - calcKDAFee estimatedGasLimit - (P.GasPrice $ P.ParsedDecimal minGasPrice) - - estimatedGasLimit = P.GasLimit $ P.ParsedInteger $! case tx of - ConstructTransfer {} -> defGasUnitsTransferCreate - - -- Calculate the maximum gas price possible give the max fee provided and the - -- needed gas units for the specified transaction. - -- NOTE: The max fee acts as upper bound on the suggested fee - -- (regardless of the multiplier provided). - calcMaxGasPrice :: P.GasLimit -> Decimal -> Decimal - calcMaxGasPrice gasLimit maxFee = fromIntegral maxGasPrice - where - P.GasLimit (P.ParsedInteger units) = gasLimit - maxGasPrice :: Integer = floor (maxFee / fromInteger units) - - -- Sanitize the fee multiplier provided by user. - -- Since the multiplier will multiplied into the min gas price, - -- (1) Makes sure that it's not zero. - -- (2) Makes sure that it's above 1.0, otherwise the final gas price - -- will be lower than the min precision allowed in Pact. - mult :: Decimal - mult = realToFrac $ - case someMult of - Nothing -> 1.0 - Just m - | m <= 1.0 -> 1.0 - | otherwise -> m - - calcGasPrice :: Maybe Decimal -> P.GasPrice - calcGasPrice someMaxGasPrice = P.GasPrice $ P.ParsedDecimal $! - case someMaxGasPrice of - Nothing -> minGasPrice * mult -- no max fee provided - Just maxGasPrice - | (minGasPrice * mult) > maxGasPrice -> maxGasPrice - | otherwise -> minGasPrice * mult - - calcKDAFee :: P.GasLimit -> P.GasPrice -> Decimal - calcKDAFee gasLimit gasPrice = fee - where - P.GasLimit (P.ParsedInteger units) = gasLimit - P.GasPrice (P.ParsedDecimal price) = gasPrice - fee = fromIntegral units * price - - --------------------------------------------------------------------------------- --- /metadata - -toPublicMeta - :: ChainId - -> AccountId - -> P.GasLimit - -> P.GasPrice - -> IO P.PublicMeta -toPublicMeta cid acct gasLimit gasPrice = do - creationTime <- toTxCreationTime <$> getCurrentTimeIntegral - - pure $ P.PublicMeta - { P._pmChainId = P.ChainId $ chainIdToText cid - , P._pmSender = _accountId_address acct - , P._pmGasLimit = gasLimit - , P._pmGasPrice = gasPrice - , P._pmTTL = defaultTransactionTTL - , P._pmCreationTime = creationTime - } - where - defaultTransactionTTL = P.TTLSeconds (8 * 60 * 60) -- 8 hours - - -toNonce :: Maybe T.Text -> P.PublicMeta -> T.Text -toNonce (Just nonce) _ = nonce -toNonce Nothing pm = sshow $! P._pmCreationTime pm - -rosettaAccountIdtoKAccount :: AccountId -> Either RosettaError (T2 T.Text P.KeySet) -rosettaAccountIdtoKAccount acct = do - let kAccount = _accountId_address acct - ownership <- toRosettaError RosettaInvalidKAccount $ - note (show acct) $ - generateKeySetFromKAccount kAccount - pure $! T2 kAccount ownership - -rosettaPubKeyTokAccount :: RosettaPublicKey -> Either RosettaError (T2 T.Text P.KeySet) -rosettaPubKeyTokAccount (RosettaPublicKey pubKey curve) = do - _ <- getScheme curve -- enforce only valid schemes - let pubKeyPact = P.PublicKeyText pubKey - kAccount <- toRosettaError RosettaInvalidPublicKey $ - note (show pubKey) $ - generateKAccountFromPubKey pubKeyPact - let ownership = pubKeyToKAccountKeySet pubKeyPact - pure $! T2 kAccount ownership - -toPactPubKeyAddr - :: T.Text - -> Either RosettaError T.Text -toPactPubKeyAddr pk = do - bs <- toRosettaError RosettaInvalidPublicKey $! P.parseB16TextOnly pk - pure $! P.toB16Text bs - - -signerToAddr :: Signer -> Either RosettaError T.Text -signerToAddr (Signer _ pk someAddr _) = do - let addr = fromMaybe pk someAddr - toPactPubKeyAddr addr - - -getScheme :: CurveType -> Either RosettaError P.PPKScheme -getScheme CurveEdwards25519 = pure P.ED25519 -getScheme ct = Left $ stringRosettaError RosettaInvalidPublicKey $ - "Found unsupported CurveType: " ++ show ct - -sigToScheme :: RosettaSignatureType -> Either RosettaError P.PPKScheme -sigToScheme RosettaEd25519 = pure P.ED25519 -sigToScheme st = Left $ stringRosettaError RosettaInvalidSignature $ - "Found unsupported SignatureType: " ++ show st - - -newtype AccountName = AccountName { _accountName :: T.Text } - deriving (Show, Eq, Ord) -instance Hashable AccountName where - hash (AccountName n) = hash n - hashWithSalt i (AccountName n) = hashWithSalt i n - --- TODO: If AccountId metadata changes to include the account guard, --- will need to ask for keyset here. -acctNameToAcctId :: AccountName -> AccountId -acctNameToAcctId (AccountName name) = accountId name - - --------------------------------------------------------------------------------- --- /payloads - -data PayloadsMetaData = PayloadsMetaData - { _payloadsMetaData_signers :: ![(Signer, AccountId)] - , _payloadsMetaData_nonce :: !T.Text - , _payloadsMetaData_publicMeta :: !P.PublicMeta - , _payloadsMetaData_tx :: !ConstructionTx - -- ^ Needed to construct gas payer AccountId - } deriving (Show) -instance ToObject PayloadsMetaData where - toPairs (PayloadsMetaData signers nonce pm tx) = - [ "signers" .= fmap (first toLegacyJsonViaEncode) signers - , "nonce" .= nonce - , "public_meta" .= toLegacyJsonViaEncode pm - , "tx" .= tx - ] - toObject m = KM.fromList (toPairs m) -instance FromJSON PayloadsMetaData where - parseJSON = withObject "PayloadsMetaData" $ \o -> do - signers <- o .: "signers" - nonce <- o .: "nonce" - publicMeta <- o .: "public_meta" - tx <- o .: "tx" - pure PayloadsMetaData - { _payloadsMetaData_signers = signers - , _payloadsMetaData_nonce = nonce - , _payloadsMetaData_publicMeta = publicMeta - , _payloadsMetaData_tx = tx - } - - -data EnrichedCommand = EnrichedCommand - { _enrichedCommand_cmd :: !(Command T.Text) - , _enrichedCommand_txInfo :: !ConstructionTx - , _enrichedCommand_signerAccounts :: ![AccountId] - } deriving (Show) -instance ToJSON EnrichedCommand where - toJSON (EnrichedCommand cmd tx accts) = object - [ "cmd" .= toLegacyJsonViaEncode cmd - , "tx_info" .= tx - , "signer_accounts" .= accts ] -instance FromJSON EnrichedCommand where - parseJSON = withObject "EnrichedCommand" $ \o -> do - cmd <- o .: "cmd" - txInfo <- o .: "tx_info" - accts <- o .: "signer_accounts" - pure EnrichedCommand - { _enrichedCommand_cmd = cmd - , _enrichedCommand_txInfo = txInfo - , _enrichedCommand_signerAccounts = accts - } - - -enrichedCommandToText :: EnrichedCommand -> T.Text -enrichedCommandToText = T.decodeUtf8 . BSL.toStrict . encode - -textToEnrichedCommand :: T.Text -> Maybe EnrichedCommand -textToEnrichedCommand = decodeStrict' . T.encodeUtf8 - -transferCreateCode :: AccountId -> (AccountId, P.KeySet) -> P.ParsedDecimal -> (T.Text, Value) -transferCreateCode from (to, toGuard) amt = - let code = T.pack $! printf - "(coin.transfer-create %s %s (read-keyset %s) (read-decimal %s))" - (acctTostr from) (acctTostr to) (show guardName) (show amountName) - rdata = object - [ guardName .= toLegacyJsonViaEncode toGuard - , amountName .= toLegacyJsonViaEncode amt ] - in (code, rdata) - where - acctTostr = show . T.unpack . _accountId_address - amountName = "amount" - guardName = "ks" - -constructionTxToPactRPC - :: ConstructionTx - -> P.PactRPC T.Text -constructionTxToPactRPC txInfo = - case txInfo of - ConstructTransfer from _ to toGuard amt -> - let (code, rdata) = transferCreateCode from (to, toGuard) amt - in P.Exec $ P.ExecMsg code (toLegacyJson rdata) - - --- | Creates an enriched Command that consists of an --- unsigned Command object, as well as any extra information lost --- when constructing the command but needed in the /parse --- endpoint. -createUnsignedCmd :: ChainwebVersion -> PayloadsMetaData -> IO EnrichedCommand -createUnsignedCmd v meta = do - cmd <- mkUnsignedCommand pactSigners [] pubMeta nonce networkId pactRPC - let cmdText = T.decodeUtf8 <$> cmd - pure $ EnrichedCommand cmdText txInfo signerAccts - where - PayloadsMetaData signers nonce pubMeta txInfo = meta - signerAccts = map snd signers - pactSigners = map fst signers - networkId = Just $! P.NetworkId $! getChainwebVersionName $ _versionName v - pactRPC = constructionTxToPactRPC txInfo - - -createSigningPayloads - :: EnrichedCommand - -> [(Signer, AccountId)] - -> [RosettaSigningPayload] -createSigningPayloads (EnrichedCommand cmd _ _) = map f - where - hashBase16 = P.toB16Text $! BS.fromShort $! P.unHash $! - P.toUntypedHash $! _cmdHash cmd - - f (signer, acct) = RosettaSigningPayload - { _rosettaSigningPayload_address = Nothing - , _rosettaSigningPayload_accountIdentifier = Just acct - , _rosettaSigningPayload_hexBytes = hashBase16 - , _rosettaSigningPayload_signatureType = toRosettaSigType $ _siScheme signer - } - - toRosettaSigType Nothing = Just RosettaEd25519 - toRosettaSigType (Just P.ED25519) = Just RosettaEd25519 - toRosettaSigType (Just P.WebAuthn) = Nothing - -- TODO: Linda Ortega (09/18/2023) -- Returning `Nothing` to discourage using WebAuthn for Rosetta. `sigToScheme` will eventually throw an error. - --------------------------------------------------------------------------------- --- /parse - -txToOps :: ConstructionTx -> [Operation] -txToOps txInfo = case txInfo of - ConstructTransfer from fromGuard to toGuard (P.ParsedDecimal amt) -> - [ op (_accountId_address from) (negate amt) (toLegacyJsonViaEncode fromGuard) 0 - , op (_accountId_address to) amt (toLegacyJsonViaEncode toGuard) 1 - ] - - where - op name delta guard idx = - o { _operation_status = "" } - -- validator expects empty op status - where o = operation - Successful - TransferOrCreateAcct - (toAcctLog name delta guard) - idx - [] - - toAcctLog name delta guard = AccountLog - { _accountLogKey = name - , _accountLogBalanceDelta = BalanceDelta delta - , _accountLogCurrGuard = toJSON guard - , _accountLogPrevGuard = toJSON guard - } - - --------------------------------------------------------------------------------- --- /combine - -getCmdPayload - :: Command T.Text - -> Either RosettaError (Payload P.PublicMeta T.Text) -getCmdPayload (Command p _ _) = - note (rosettaError' RosettaUnparsableTx) - (decodeStrict' $! T.encodeUtf8 p) - - --- TODO: This assumes Rosettas signatures are all Ed25519 signatures --- (Not webauthn). -matchSigs - :: [RosettaSignature] - -> [Signer] - -> Either RosettaError [UserSig] -matchSigs sigs signers = do - sigMap <- HM.fromList <$> mapM sigAndAddr sigs - mapM (match sigMap) signers - - where - match - :: HM.HashMap T.Text UserSig - -> Signer - -> Either RosettaError UserSig - match m signer = do - addr <- signerToAddr signer - note (stringRosettaError RosettaInvalidSignature - $ "Missing signature for public key=" ++ show (_siPubKey signer)) - $ HM.lookup addr m - - sigAndAddr (RosettaSignature _ (RosettaPublicKey pk ct) sigTyp sig) = do - sigScheme <- sigToScheme sigTyp - pkScheme <- getScheme ct - when (sigScheme /= pkScheme) - (Left $ stringRosettaError RosettaInvalidSignature $ - "Expected the same Signature and PublicKey type for Signature=" ++ show sig) - - let userSig = P.ED25519Sig sig - addr <- toPactPubKeyAddr pk - pure (addr, userSig) - --------------------------------------------------------------------------------- --- Rosetta Helper Types -- --------------------------------------------------------------------------------- - -type CoinbaseTx chainwebTx = chainwebTx -newtype BalanceDelta = BalanceDelta { _balanceDelta :: Decimal } - deriving (Show, Eq) -data AccountLog = AccountLog - { _accountLogKey :: !T.Text - , _accountLogBalanceDelta :: !BalanceDelta - , _accountLogCurrGuard :: !Value - , _accountLogPrevGuard :: !Value - } - deriving (Show, Eq) -type AccountRow = (T.Text, Decimal, Value) - --- | An operation index and related operations can only be --- determined once all operations in a transaction are known. -type UnindexedOperation = - Word64 - -- ^ Operation index - -> [OperationId] - -- ^ Id of Related Operations - -> Operation - -data UnindexedOperations = UnindexedOperations - { _unindexedOperation_fundOps :: [UnindexedOperation] - , _unindexedOperation_transferOps :: [UnindexedOperation] - , _unindexedOperation_gasOps :: [UnindexedOperation] - } - -data ChainwebOperationStatus = Successful | Remediation - deriving (Enum, Bounded, Show) - -data OperationType = - CoinbaseReward - | FundTx - | GasPayment - | TransferOrCreateAcct - deriving (Enum, Bounded, Show) - - --------------------------------------------------------------------------------- --- Functions to create Rosetta types -- --------------------------------------------------------------------------------- - --- | If its the genesis block, Rosetta wants the parent block to be itself. --- Otherwise, fetch the parent header from the block. -parentBlockId :: BlockHeader -> BlockId -parentBlockId bh - | bHeight == genesisHeight v cid = blockId bh -- genesis - | otherwise = parent - where - bHeight = view blockHeight bh - cid = view blockChainId bh - v = view chainwebVersion bh - parent = BlockId - { _blockId_index = getBlockHeight (pred $ view blockHeight bh) - , _blockId_hash = blockHashToText (view blockParent bh) - } - -blockId :: BlockHeader -> BlockId -blockId bh = BlockId - { _blockId_index = getBlockHeight (view blockHeight bh) - , _blockId_hash = blockHashToText (view blockHash bh) - } - -cmdToTransactionId :: Command T.Text -> TransactionId -cmdToTransactionId = TransactionId . requestKeyToB16Text . cmdToRequestKey - -rosettaTransactionFromCmd :: Command a -> [Operation] -> Transaction -rosettaTransactionFromCmd cmd ops = - Transaction - { _transaction_transactionId = pactHashToTransactionId (_cmdHash cmd) - , _transaction_operations = ops - , _transaction_metadata = Nothing - } - -rosettaTransaction :: CommandResult a -> ChainId -> [Operation] -> Transaction -rosettaTransaction cr cid ops = - Transaction - { _transaction_transactionId = rkToTransactionId (_crReqKey cr) - , _transaction_operations = ops - , _transaction_metadata = Just $ toObject (transactionMetaData cid cr) - } - -pactHashToTransactionId :: P.PactHash -> TransactionId -pactHashToTransactionId hsh = TransactionId $ P.hashToText $ P.toUntypedHash hsh - -rkToTransactionId :: RequestKey -> TransactionId -rkToTransactionId rk = TransactionId $ requestKeyToB16Text rk - -accountId :: T.Text -> AccountId -accountId acctName = AccountId - { _accountId_address = acctName - , _accountId_subAccount = Nothing -- assumes coin acct contract only - , _accountId_metadata = Nothing -- disabled due to ownership rotation bug - } - where - _accountIdMeta = Nothing - -operationStatus :: ChainwebOperationStatus -> OperationStatus -operationStatus s@Successful = - OperationStatus - { _operationStatus_status = sshow s - , _operationStatus_successful = True - } -operationStatus s@Remediation = - OperationStatus - { _operationStatus_status = sshow s - , _operationStatus_successful = True - } - --- | Flatten operations grouped by TxId into a single list of operations; --- give each operation a unique, numerical operation id based on its position --- in this new flattened list; and create DAG of related operations. -indexedOperations :: UnindexedOperations -> [Operation] -indexedOperations unIdxOps = fundOps <> transferOps <> gasOps - where - opIds = map _operation_operationId - - createOps opsF begIdx defRelatedOpIds = - let ops = zipWith (\f i -> f i defRelatedOpIds) opsF [begIdx..] - in weaveRelatedOperations $! ops - -- connect operations to each other - - fundUnIdxOps = _unindexedOperation_fundOps $! unIdxOps - fundOps = createOps fundUnIdxOps 0 [] - - transferIdx = fromIntegral $! length fundOps - transferUnIdxOps = _unindexedOperation_transferOps $! unIdxOps - transferOps = createOps transferUnIdxOps transferIdx [] - - gasIdx = transferIdx + (fromIntegral $! length transferOps) - gasUnIdxOps = _unindexedOperation_gasOps $! unIdxOps - gasOps = createOps gasUnIdxOps gasIdx (opIds $! fundOps) - -- connect gas operations to fund operations - --- | Create a DAG of related operations. --- Algorithm: --- Given a list of operations that are related: --- For operation x at position i, --- Overwrite or append all operations ids at --- position 0th to ith (not inclusive) to operation x's --- related operations list. --- Example: list of operations to weave: [ 4: [], 5: [1], 6: [] ] --- weaved operations: [ 4: [], 5: [1, 4], 6: [4, 5] ] -weaveRelatedOperations :: [Operation] -> [Operation] -weaveRelatedOperations relatedOps = map weave opsWithRelatedOpIds - where - -- example: [1, 2, 3] -> [[], [1], [1,2], [1,2,3]] - opIdsDAG = inits $! map _operation_operationId relatedOps - -- example: [(op 1, []), (op 2, [1]), (op 3, [1,2])] - opsWithRelatedOpIds = zip relatedOps opIdsDAG - - -- related operation ids must be in descending order. - justSortRelated r = Just $! sortOn _operationId_index r - - weave (op, newRelatedIds) = - case newRelatedIds of - [] -> op -- no new related operations to add - l -> case _operation_relatedOperations op of - Nothing -> op -- no previous related operations - { _operation_relatedOperations = justSortRelated l } - Just oldRelatedIds -> op - { _operation_relatedOperations = justSortRelated $! (oldRelatedIds <> l) } - -operation - :: ChainwebOperationStatus - -> OperationType - -> AccountLog - -> Word64 - -> [OperationId] - -> Operation -operation ostatus otype acctLog idx related = - Operation - { _operation_operationId = OperationId idx Nothing - , _operation_relatedOperations = someRelatedOps - , _operation_type = sshow otype - , _operation_status = sshow ostatus - , _operation_account = Just $ accountId (_accountLogKey acctLog) - , _operation_amount = Just $ kdaToRosettaAmount $ - _balanceDelta $ _accountLogBalanceDelta acctLog - , _operation_coinChange = Nothing - , _operation_metadata = opMeta - } - where - someRelatedOps = case related of - [] -> Nothing - li -> Just li - opMeta = Just $ toObject $ OperationMetaData - { _operationMetaData_prevOwnership = _accountLogPrevGuard acctLog - , _operationMetaData_currOwnership = _accountLogCurrGuard acctLog - } - -parseOp - :: Operation - -> Either RosettaError (AccountId, P.ParsedDecimal, P.KeySet) -parseOp (Operation i _ typ stat someAcct someAmt _ someMeta) = do - typ @?= "TransferOrCreateAcct" - stat @?= "Successful" - acct <- someAcct @?? "Missing AccountId" - amtDelta <- someAmt @?? "Missing Amount" >>= parseAmount - (OperationMetaData prevOwn currOwn) <- someMeta @?? "Missing metadata" - >>= extractMetaData - prevOwn @?= currOwn -- ensure that the ownership wasn't rotated - ownership <- hushResult (fromJSON currOwn) @?? - "Only Pact KeySet is supported for account ownership" - - pure (acct, P.ParsedDecimal amtDelta, ownership) - - where - (@??) :: Maybe a -> String -> Either RosettaError a - Nothing @?? msg = - Left $ stringRosettaError RosettaInvalidOperation $ - "Operation id=" ++ show i ++ ": " ++ msg - (Just a) @?? _ = pure a - - (@?=) - :: (Show a, Eq a) => a - -> a - -> Either RosettaError () - actual @?= expected - | actual == expected = pure () - | otherwise = - Left $ stringRosettaError RosettaInvalidOperation $ - "Operation id=" ++ show i ++ ": expected " ++ show expected - ++ " but received " ++ show actual - - --- | Timestamp of the block in milliseconds since the Unix Epoch. --- NOTE: Chainweb provides this timestamp in microseconds. -rosettaTimestamp :: BlockHeader -> Word64 -rosettaTimestamp bh = BA.unLE . BA.toLE $ fromInteger msTime - where - msTime = int $ microTime `div` ms - TimeSpan ms = millisecond - microTime = encodeTimeToWord64 $ _bct (view blockCreationTime bh) - - --- | How to convert from atomic units to standard units in Rosetta Currency. -defaultNumOfDecimals :: Word -defaultNumOfDecimals = 12 - -defaultCurrency :: Currency -defaultCurrency = Currency "KDA" defaultNumOfDecimals Nothing - -kdaToRosettaAmount :: Decimal -> Amount -kdaToRosettaAmount k = Amount (sshow amount) defaultCurrency Nothing - where - -- Value in atomic units represented as an arbitrary-sized signed integer. - amount :: Integer - amount = floor $ k * realToFrac ((10 :: Integer) ^ defaultNumOfDecimals) - -parseAmount :: Amount -> Either RosettaError Decimal -parseAmount a@(Amount txt (Currency _ numDecs _) _) = do - validateCurrency (_amount_currency a) - P.ParsedInteger i <- f $ String txt - pure $ Decimal (fromIntegral numDecs) i - where - f = toRosettaError RosettaInvalidAmount . noteResult . fromJSON - -validateCurrency :: Currency -> Either RosettaError () -validateCurrency curr - | curr /= defaultCurrency = - Left $ stringRosettaError RosettaInvalidAmount $ - "Expected currency " ++ show defaultCurrency ++ - " but received currency " ++ show curr - | otherwise = pure () - --------------------------------------------------------------------------------- --- Rosetta Exceptions -- --------------------------------------------------------------------------------- - -data RosettaFailure - = RosettaChainUnspecified - | RosettaInvalidChain - | RosettaMempoolBadTx - | RosettaUnparsableTx - | RosettaInvalidTx - | RosettaInvalidBlockchainName - | RosettaMismatchNetworkName - | RosettaPactExceptionThrown - | RosettaExpectedBalDecimal - | RosettaInvalidResultMetaData - | RosettaSubAcctUnsupported - | RosettaMismatchTxLogs - | RosettaUnparsableTxLog - | RosettaInvalidBlockHeight - | RosettaBlockHashNotFound - | RosettaUnparsableBlockHash - | RosettaOrphanBlockHash - | RosettaMismatchBlockHashHeight - | RosettaPayloadNotFound - | RosettaUnparsableTxOut - | RosettaTxIdNotFound - | RosettaUnparsableTransactionId - | RosettaInvalidAccountKey - | RosettaUnparsableMetaData - | RosettaMissingMetaData - | RosettaMissingPublicKeys - | RosettaMissingExpectedPublicKey - | RosettaInvalidAmount - | RosettaInvalidOperation - | RosettaInvalidOperations - | RosettaInvalidPublicKey - | RosettaInvalidSignature - | RosettaInvalidAccountProvided - | RosettaInvalidKAccount - | RosettaConstructionApiDeprecated - deriving (Show, Enum, Bounded, Eq) - - --- TODO: Better grouping of rosetta error index? -rosettaError :: RosettaFailure -> Maybe Object -> RosettaError -rosettaError RosettaChainUnspecified = RosettaError 0 "No SubNetwork (chain) specified" False -rosettaError RosettaInvalidChain = RosettaError 1 "Invalid SubNetwork (chain) value" False -rosettaError RosettaMempoolBadTx = RosettaError 2 "Transaction not present in mempool" False -rosettaError RosettaUnparsableTx = RosettaError 3 "Transaction not parsable" False -rosettaError RosettaInvalidTx = RosettaError 4 "Invalid transaction" False -rosettaError RosettaInvalidBlockchainName = RosettaError 5 "Invalid blockchain name" False -rosettaError RosettaMismatchNetworkName = RosettaError 6 "Invalid Chainweb network name" False -rosettaError RosettaPactExceptionThrown = - RosettaError 7 "A pact exception was thrown" False -- TODO if retry could succeed -rosettaError RosettaExpectedBalDecimal = RosettaError 8 "Expected balance as a decimal" False -rosettaError RosettaInvalidResultMetaData = RosettaError 9 "Invalid meta data field in command result" False -rosettaError RosettaSubAcctUnsupported = RosettaError 10 "Sub account identifier is not supported" False -rosettaError RosettaMismatchTxLogs = - RosettaError 11 "Unable to match transactions to transaction logs as expected" False -rosettaError RosettaUnparsableTxLog = RosettaError 12 "TxLogs not parsable" False -rosettaError RosettaInvalidBlockHeight = RosettaError 13 "Invalid block height" False -- TODO if retry could succeed -rosettaError RosettaBlockHashNotFound = RosettaError 14 "Block hash was not found" False -rosettaError RosettaUnparsableBlockHash = RosettaError 15 "Block hash not parsable" False -rosettaError RosettaOrphanBlockHash = RosettaError 16 "Block hash not in the latest fork" False -rosettaError RosettaMismatchBlockHashHeight = RosettaError 17 "Block hash and block height did not match" False -rosettaError RosettaPayloadNotFound = RosettaError 18 "Block payload not found" False -rosettaError RosettaUnparsableTxOut = RosettaError 19 "Transaction output not parsable" False -rosettaError RosettaTxIdNotFound = RosettaError 20 "Transaction Id not found in block" False -rosettaError RosettaUnparsableTransactionId = RosettaError 21 "Transaction Id not parsable" False -rosettaError RosettaInvalidAccountKey = RosettaError 22 "Invalid AccountId address" False -rosettaError RosettaUnparsableMetaData = RosettaError 24 "Unparsable metadata field" False -rosettaError RosettaMissingMetaData = RosettaError 25 "Required metadata field is missing" False -rosettaError RosettaMissingPublicKeys = RosettaError 26 "Required public_keys field is missing" False -rosettaError RosettaMissingExpectedPublicKey = RosettaError 27 "Expected public key not provided" False -rosettaError RosettaInvalidAmount = RosettaError 28 "Invalid Amount type" False -rosettaError RosettaInvalidOperation = RosettaError 29 "Invalid Operation type" False -rosettaError RosettaInvalidOperations = RosettaError 30 "Invalid Operations list found" False -rosettaError RosettaInvalidPublicKey = RosettaError 31 "Invalid PublicKey" False -rosettaError RosettaInvalidSignature = RosettaError 32 "Invalid Signature" False -rosettaError RosettaInvalidAccountProvided = RosettaError 33 "Invalid Account was provided" False -rosettaError RosettaInvalidKAccount = RosettaError 34 "Invalid k:Account" False -rosettaError RosettaConstructionApiDeprecated = RosettaError 35 "The construction API is deprecated. It is disabled by default and can be enabled via the 'rosettaConstructionApi' configuration flag" False - -rosettaError' :: RosettaFailure -> RosettaError -rosettaError' f = rosettaError f Nothing - -stringRosettaError :: RosettaFailure -> String -> RosettaError -stringRosettaError e msg = rosettaError e $ Just $ - KM.fromList ["error_message" .= msg ] - --------------------------------------------------------------------------------- --- Misc Helper Functions -- --------------------------------------------------------------------------------- - -maybePair :: (ToJSON a) => Key -> Maybe a -> (Key, Maybe Value) -maybePair name Nothing = (name, Nothing) -maybePair name (Just v) = (name, Just (toJSON v)) - -toPairOmitMaybe :: [Pair] -> [(Key, Maybe Value)] -> [Pair] -toPairOmitMaybe defPairs li = allPairs - where - allPairs = foldl' f defPairs li - f acc (_, Nothing) = acc - f acc (t, Just p) = acc ++ [t .= p] - -toJSONOmitMaybe :: [Pair] -> [(Key, Maybe Value)] -> Value -toJSONOmitMaybe defPairs li = object $ toPairOmitMaybe defPairs li - -toRosettaError - :: RosettaFailure - -> Either String a - -> Either RosettaError a -toRosettaError failure = annotate (stringRosettaError failure) - - -ksToPubKeys :: P.KeySet -> [T.Text] -ksToPubKeys (P.KeySet pkSet _) = - map P._pubKey (S.toList pkSet) - - -parsePubKeys :: T.Text -> Value -> Either RosettaError [T.Text] -parsePubKeys k v = do - g :: (P.Guard PactValue) <- toRosettaError RosettaInvalidAccountProvided - $ noteResult $ fromJSON v - case g of - P.GUser _ -> pure [] - P.GKeySet ks -> pure $ ksToPubKeys ks - _ -> Left $ stringRosettaError RosettaInvalidAccountProvided $ - "Account=" ++ show k ++ - ": Rosetta only supports ownership of type UserGuard and KeySet" - - -extractMetaData :: (FromJSON a) => Object -> Either RosettaError a -extractMetaData = toRosettaError RosettaUnparsableMetaData - . noteResult . fromJSON . Object - --- | Guarantees that the `ChainId` given actually belongs to this --- `ChainwebVersion`. This doesn't guarantee that the chain is active. --- -readChainIdText :: ChainwebVersion -> T.Text -> Maybe ChainId -readChainIdText v c = do - cid <- readMaybe @Word32 (T.unpack c) - mkChainId v maxBound cid - --- TODO: document -maxRosettaNodePeerLimit :: Natural -maxRosettaNodePeerLimit = 64 - -rowDataToAccountLog :: AccountRow -> Maybe AccountRow -> AccountLog -rowDataToAccountLog (currKey, currBal, currGuard) prev = do - case prev of - Nothing -> - -- First time seeing account - AccountLog - { _accountLogKey = currKey - , _accountLogBalanceDelta = BalanceDelta currBal - , _accountLogCurrGuard = currGuard - , _accountLogPrevGuard = currGuard - } - Just (_, prevBal, prevGuard) -> - -- Already seen this account - AccountLog - { _accountLogKey = currKey - , _accountLogBalanceDelta = BalanceDelta (currBal - prevBal) - , _accountLogCurrGuard = currGuard - , _accountLogPrevGuard = prevGuard - } - --- | Parse TxLog Value into fungible asset account columns -txLogToAccountRow :: PCore.TxLog PCore.RowData -> Maybe AccountRow -txLogToAccountRow (PCore.TxLog _ key (PCore.RowData row)) = do - LegacyValue guard <- (maybe (error "txLogToAccountRow: can't decode PactValue") id . J.decodeStrict . PCore.encodeStable) <$> M.lookup (PCore.Field "guard") row - case M.lookup (PCore.Field "balance") row of - Just (PCore.PLiteral (PCore.LDecimal bal)) -> pure (key, bal, guard) - _ -> Nothing - -hushResult :: Result a -> Maybe a -hushResult (Success w) = Just w -hushResult (Error _) = Nothing - -noteResult :: Result a -> Either String a -noteResult (Success w) = Right w -noteResult (Error e) = Left e - -annotate :: (a -> c) -> Either a b -> Either c b -annotate f (Left e) = Left $ f e -annotate _ (Right r) = Right r - -overwriteError :: a -> Either b c -> Either a c -overwriteError e (Left _) = Left e -overwriteError _ (Right r) = Right r - -noteOptional :: a -> Either a (Maybe c) -> Either a c -noteOptional e (Right Nothing) = Left e -noteOptional _ (Right (Just c)) = pure c -noteOptional _ (Left oe) = Left oe diff --git a/test/lib/Chainweb/Test/RestAPI/Utils.hs b/test/lib/Chainweb/Test/RestAPI/Utils.hs index 1d6add486e..02d7d27f73 100644 --- a/test/lib/Chainweb/Test/RestAPI/Utils.hs +++ b/test/lib/Chainweb/Test/RestAPI/Utils.hs @@ -25,24 +25,6 @@ module Chainweb.Test.RestAPI.Utils , pollingWithDepth , getCurrentBlockHeight - -- * Rosetta client DSL -, RosettaTestException(..) -, accountBalance -, blockTransaction -, block -, constructionDerive -, constructionPreprocess -, constructionMetadata -, constructionPayloads -, constructionParse -, constructionCombine -, constructionHash -, constructionSubmit -, mempoolTransaction -, mempool -, networkOptions -, networkList -, networkStatus ) where @@ -57,8 +39,6 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Network.HTTP.Types.Status (Status(..)) -import Rosetta - import Servant.Client -- internal chainweb modules @@ -70,7 +50,6 @@ import Chainweb.CutDB.RestAPI.Client import Chainweb.Pact.RestAPI.Client import Chainweb.Pact.RestAPI.EthSpv import Chainweb.Pact.Types -import Chainweb.Rosetta.RestAPI.Client import Chainweb.Version import Chainweb.Test.Utils @@ -303,333 +282,6 @@ getCurrentBlockHeight сv cenv cid = Left e -> throwM $ GetBlockHeightFailure $ "Failed to get cuts: " ++ show e Right cuts -> return $ fromJust $ _bhwhHeight <$> HM.lookup cid (_cutHashes cuts) --- ------------------------------------------------------------------ -- --- Rosetta api client utils w/ retry - -data RosettaTestException - = AccountBalanceFailure String - | BlockTransactionFailure String - | BlockFailure String - | ConstructionPreprocessFailure String - | ConstructionMetadataFailure String - | ConstructionPayloadsFailure String - | ConstructionParseFailure String - | ConstructionCombineFailure String - | ConstructionHashFailure String - | ConstructionSubmitFailure String - | MempoolTransactionFailure String - | MempoolFailure String - | NetworkListFailure String - | NetworkOptionsFailure String - | NetworkStatusFailure String - deriving Show - -instance Exception RosettaTestException - -accountBalance - :: ChainwebVersion - -> ClientEnv - -> AccountBalanceReq - -> IO AccountBalanceResp -accountBalance v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting account balance for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaAccountBalanceApiClient v req) cenv >>= \case - Left e -> throwM $ AccountBalanceFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - AccountBalanceFailure _ -> return True - _ -> return False - -blockTransaction - :: ChainwebVersion - -> ClientEnv - -> BlockTransactionReq - -> IO BlockTransactionResp -blockTransaction v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting block transaction for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaBlockTransactionApiClient v req) cenv >>= \case - Left e -> throwM $ BlockTransactionFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - BlockTransactionFailure _ -> return True - _ -> return False - -block - :: ChainwebVersion - -> ClientEnv - -> BlockReq - -> IO BlockResp -block v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting block for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaBlockApiClient v req) cenv >>= \case - Left e -> throwM $ BlockFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - BlockFailure _ -> return True - _ -> return False - -constructionDerive - :: ChainwebVersion - -> ClientEnv - -> ConstructionDeriveReq - -> IO ConstructionDeriveResp -constructionDerive v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting derive preprocess for " <> (show req) - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionDeriveApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionPreprocessFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionPreprocessFailure _ -> return True - _ -> return False - -constructionPreprocess - :: ChainwebVersion - -> ClientEnv - -> ConstructionPreprocessReq - -> IO ConstructionPreprocessResp -constructionPreprocess v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting construction preprocess for " <> (show req) - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionPreprocessApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionPreprocessFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionPreprocessFailure _ -> return True - _ -> return False - -constructionMetadata - :: ChainwebVersion - -> ClientEnv - -> ConstructionMetadataReq - -> IO ConstructionMetadataResp -constructionMetadata v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting construction metadata for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionMetadataApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionMetadataFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionMetadataFailure _ -> return True - _ -> return False - -constructionPayloads - :: ChainwebVersion - -> ClientEnv - -> ConstructionPayloadsReq - -> IO ConstructionPayloadsResp -constructionPayloads v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting construction payloads for " <> (show req) - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionPayloadsApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionPayloadsFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionPayloadsFailure _ -> return True - _ -> return False - -constructionParse - :: ChainwebVersion - -> ClientEnv - -> ConstructionParseReq - -> IO ConstructionParseResp -constructionParse v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting construction parse for " <> (show req) - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionParseApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionParseFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionParseFailure _ -> return True - _ -> return False - -constructionCombine - :: ChainwebVersion - -> ClientEnv - -> ConstructionCombineReq - -> IO ConstructionCombineResp -constructionCombine v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting construction combine for " <> (show req) - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionCombineApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionCombineFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionCombineFailure _ -> return True - _ -> return False - -constructionHash - :: ChainwebVersion - -> ClientEnv - -> ConstructionHashReq - -> IO TransactionIdResp -constructionHash v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting construction hash for " <> (show req) - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionHashApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionHashFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionHashFailure _ -> return True - _ -> return False - -constructionSubmit - :: ChainwebVersion - -> ClientEnv - -> ConstructionSubmitReq - -> IO TransactionIdResp -constructionSubmit v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting construction submit for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaConstructionSubmitApiClient v req) cenv >>= \case - Left e -> throwM $ ConstructionSubmitFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - ConstructionSubmitFailure _ -> return True - _ -> return False - -mempoolTransaction - :: ChainwebVersion - -> ClientEnv - -> MempoolTransactionReq - -> IO MempoolTransactionResp -mempoolTransaction v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting mempool transaction for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaMempoolTransactionApiClient v req) cenv >>= \case - Left e -> throwM $ MempoolTransactionFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - MempoolTransactionFailure _ -> return True - _ -> return False - -mempool - :: ChainwebVersion - -> ClientEnv - -> NetworkReq - -> IO MempoolResp -mempool v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting mempool for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaMempoolApiClient v req) cenv >>= \case - Left e -> throwM $ MempoolFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - MempoolFailure _ -> return True - _ -> return False - -networkList - :: ChainwebVersion - -> ClientEnv - -> MetadataReq - -> IO NetworkListResp -networkList v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting network list for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaNetworkListApiClient v req) cenv >>= \case - Left e -> throwM $ NetworkListFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - NetworkListFailure _ -> return True - _ -> return False - -networkOptions - :: ChainwebVersion - -> ClientEnv - -> NetworkReq - -> IO NetworkOptionsResp -networkOptions v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting network options for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaNetworkOptionsApiClient v req) cenv >>= \case - Left e -> throwM $ NetworkOptionsFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - NetworkOptionsFailure _ -> return True - _ -> return False - -networkStatus - :: ChainwebVersion - -> ClientEnv - -> NetworkReq - -> IO NetworkStatusResp -networkStatus v cenv req = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting network status for " <> show req - <> " [" <> show (view rsIterNumberL s) <> "]" - - runClientM (rosettaNetworkStatusApiClient v req) cenv >>= \case - Left e -> throwM $ NetworkStatusFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - NetworkStatusFailure _ -> return True - _ -> return False - clientErrorStatusCode :: ClientError -> Maybe Int clientErrorStatusCode = \case FailureResponse _ resp -> Just $ getStatusCode resp diff --git a/test/unit/Chainweb/Test/Pact4/PactSingleChainTest.hs b/test/unit/Chainweb/Test/Pact4/PactSingleChainTest.hs index b91d6cd057..f53801924b 100644 --- a/test/unit/Chainweb/Test/Pact4/PactSingleChainTest.hs +++ b/test/unit/Chainweb/Test/Pact4/PactSingleChainTest.hs @@ -134,7 +134,6 @@ tests rdb = testGroup testName , test mempoolRefillTest , test blockGasLimitTest , testTimeout preInsertCheckTimeoutTest - , rosettaFailsWithoutFullHistory rdb , rewindPastMinBlockHeightFails rdb , pactStateSamePreAndPostCompaction rdb , compactionIsIdempotent rdb @@ -333,63 +332,6 @@ toRowData v = case PCore.decodeStable $ BL.toStrict encV of where encV = J.encode v --- Test that PactService fails if Rosetta is enabled and we don't have all of --- the history. --- --- We do this in two stages: --- --- 1: --- - Start PactService with Rosetta disabled --- - Run some blocks --- - Compact to some arbitrary greater-than-genesis height --- 2: --- - Start PactService with Rosetta enabled --- - Catch the exception that should arise at the start of PactService, --- when performing the history check -rosettaFailsWithoutFullHistory :: () - => RocksDb - -> TestTree -rosettaFailsWithoutFullHistory rdb = - withTemporaryDir $ \srcDir -> withSqliteDb cid srcDir $ \srcSqlEnvIO -> - withTemporaryDir $ \targetDir -> withSqliteDb cid targetDir $ \targetSqlEnvIO -> - withDelegateMempool $ \dm -> - sequentialTestGroup "rosettaFailsWithoutFullHistory" AllSucceed - [ - -- Run some blocks and then compact - withPactTestBlockDb' testVersion cid rdb srcSqlEnvIO mempty testPactServiceConfig $ \reqIO -> - testCase "runBlocksAndCompact" $ do - (srcSqlEnv, q, bdb) <- reqIO - - mempoolRef <- fmap (pure . fst) dm - - setOneShotMempool mempoolRef =<< goldenMemPool - replicateM_ 10 $ void $ runBlock q bdb second - - targetSqlEnv <- targetSqlEnvIO - sigmaCompact srcSqlEnv targetSqlEnv (BlockHeight 5) - - -- This needs to run after the previous test - -- Annoyingly, we must inline the PactService util starts here. - -- ResourceT will help clean all this up - , testCase "PactService Should fail" $ do - pactQueue <- newPactQueue 2000 - blockDb <- mkTestBlockDb testVersion rdb - bhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) cid - sqlEnv <- targetSqlEnvIO - mempool <- fmap snd dm - let payloadDb = _bdbPayloadDb blockDb - let cfg = testPactServiceConfig { _pactFullHistoryRequired = True } - let logger = genericLogger System.LogLevel.Error (\_ -> return ()) - e <- try $ runPactService testVersion cid logger Nothing pactQueue mempool bhDb payloadDb sqlEnv cfg - case e of - Left (FullHistoryRequired {}) -> do - pure () - Left err -> do - assertFailure $ "Expected FullHistoryRequired exception, instead got: " ++ show err - Right _ -> do - assertFailure "Expected FullHistoryRequired exception, instead there was no exception at all." - ] - rewindPastMinBlockHeightFails :: () => RocksDb -> TestTree @@ -708,82 +650,6 @@ comparePactStateBeforeAndAfter statePreCompaction statePostCompaction = do putStrLn "" assertFailure "pact state check failed" --- -- Test that PactService fails if Rosetta is enabled and we don't have all of --- -- the history. --- -- --- -- We do this in two stages: --- -- --- -- 1: --- -- - Start PactService with Rosetta disabled --- -- - Run some blocks --- -- - Compact to some arbitrary greater-than-genesis height --- -- 2: --- -- - Start PactService with Rosetta enabled --- -- - Catch the exception that should arise at the start of PactService, --- -- when performing the history check --- rosettaFailsWithoutFullHistory :: () --- => RocksDb --- -> TestTree --- rosettaFailsWithoutFullHistory rdb = --- withTemporaryDir $ \iodir -> --- withSqliteDb cid iodir $ \sqlEnvIO -> --- withDelegateMempool $ \dm -> --- independentSequentialTestGroup "rosettaFailsWithoutFullHistory" --- [ --- -- Run some blocks and then compact --- withPactTestBlockDb' testVersion cid rdb sqlEnvIO mempty testPactServiceConfig $ \reqIO -> --- testCase "runBlocksAndCompact" $ do --- (sqlEnv, q, bdb) <- reqIO - --- mempoolRef <- fmap (pure . fst) dm - --- setOneShotMempool mempoolRef =<< goldenMemPool --- replicateM_ 10 $ void $ runBlock q bdb second - --- compact Error [C.NoVacuum] sqlEnv (C.Target (BlockHeight 5)) - --- -- This needs to run after the previous test --- -- Annoyingly, we must inline the PactService util starts here. --- -- ResourceT will help clean all this up --- , testCase "PactService Should fail" $ do --- pactQueue <- newPactQueue 2000 --- blockDb <- mkTestBlockDb testVersion rdb --- bhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) cid --- sqlEnv <- sqlEnvIO --- mempool <- fmap snd dm --- let payloadDb = _bdbPayloadDb blockDb --- let cfg = testPactServiceConfig { _pactFullHistoryRequired = True } --- let logger = genericLogger System.LogLevel.Error (\_ -> return ()) --- e <- try $ runPactService testVersion cid logger Nothing pactQueue mempool bhDb payloadDb sqlEnv cfg --- case e of --- Left (FullHistoryRequired {}) -> do --- pure () --- Left err -> do --- assertFailure $ "Expected FullHistoryRequired exception, instead got: " ++ show err --- Right _ -> do --- assertFailure "Expected FullHistoryRequired exception, instead there was no exception at all." --- ] - --- rewindPastMinBlockHeightFails :: () --- => RocksDb --- -> TestTree --- rewindPastMinBlockHeightFails rdb = --- compactionSetup "rewindPastMinBlockHeightFails" rdb testPactServiceConfig $ \cr -> do --- replicateM_ 10 $ runBlock cr.pactQueue cr.blockDb second - --- compact Error [C.NoVacuum] cr.sqlEnv (C.Target (BlockHeight 5)) - --- -- Genesis block header; compacted away by now --- let bh = genesisBlockHeader testVersion cid - --- syncResult <- try (pactSyncToBlock bh cr.pactQueue) --- case syncResult of --- Left (BlockHeaderLookupFailure {}) -> do --- return () --- Left err -> do --- assertFailure $ "Expected a BlockHeaderLookupFailure, but got: " ++ show err --- Right _ -> do --- assertFailure "Expected an exception, but didn't encounter one." -- pactStateSamePreAndPostCompaction :: () -- => RocksDb diff --git a/test/unit/Chainweb/Test/Rosetta.hs b/test/unit/Chainweb/Test/Rosetta.hs deleted file mode 100644 index c5d4ecb437..0000000000 --- a/test/unit/Chainweb/Test/Rosetta.hs +++ /dev/null @@ -1,640 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module: Chainweb.Test.Rosetta --- --- Unit tests for Rosetta. --- --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: MIT --- Maintainer: Linda Ortega --- Stability: experimental --- --- -module Chainweb.Test.Rosetta - ( tests - ) where - -import Control.Monad (foldM, void) -import Data.Aeson -import qualified Data.ByteString.Short as BS -import Data.Decimal -import Data.Map (Map) -import Data.Word (Word64) - -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V - -import Pact.Types.Runtime (TxId(..), RowKey(..)) -import Pact.Types.Command (RequestKey(..)) -import Pact.Types.Hash (Hash(..)) - -import Rosetta - -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Chainweb.Rosetta.Internal -import Chainweb.Rosetta.RestAPI -import Chainweb.Rosetta.Utils -import Chainweb.Version -import Chainweb.Version.RecapDevelopment -import Chainweb.Version.Testnet04 -import qualified Pact.Types.KeySet as P - ---- - - -tests :: TestTree -tests = testGroup "Chainweb.Test.Rosetta.UnitTests" - [ testCase "checkBalanceDeltas" checkBalanceDeltas - , testCase "matchNonGenesisBlockTransactionsToLogs" matchNonGenesisBlockTransactionsToLogs - , testCase "matchFailedCoinbaseBlockTransactionsToLogs" matchFailedCoinbaseBlockTransactionsToLogs - , testCase "matchNonGenesisSingleTransactionsToLogs" matchNonGenesisSingleTransactionsToLogs - , testCase "checkKDAToRosettaAmount" checkKDAToRosettaAmount - , testCase "checkValidateNetwork" checkValidateNetwork - , testCase "checkUniqueRosettaErrorCodes" checkUniqueRosettaErrorCodes - , testCase "checkTransferCodeInjection" checkTransferCodeInjection - ] - - -checkBalanceDeltas :: Assertion -checkBalanceDeltas = do - case1 >> case2 >> case3 >> case4 >> case5 >> case6 - - where - case1 = - let noPrevLogs = mockPrevTxs [] - unique = [ cases 0 [createCase "k1" 1.0 (bd 1.0)] - , cases 1 [createCase "k2" (negate 2.0) (bd $ negate 2.0)] - ] - in test "unique keys, not previously seen" noPrevLogs unique - - case2 = - let allHavePrevLogs = mockPrevTxs - [ ("k1", 1.0) - , ("k2", 2.0) - , ("k3", 3.0) - , ("k4", 4.0)] - unique = [ cases 0 [createCase "k1" 1.0 (bd 0.0)] - , cases 1 [createCase "k2" 0.0 (bd $ negate 2.0)] - , cases 2 [createCase "k3" 3.5 (bd 0.5)] - , cases 3 [createCase "k4" 5.0 (bd 1.0)] - ] - in test "unique keys, all seen before" allHavePrevLogs unique - - case3 = - let onlyOneSeenPrevLogs = mockPrevTxs [("k1", 1.0)] - unique = [ cases 0 [createCase "k1" 0.5 (bd $ negate 0.5)] - , cases 1 [createCase "k2" 2.0 (bd 2.0)] - ] - in test "unique keys, only one seen before" onlyOneSeenPrevLogs unique - - case4 = - let noPrevLogs = mockPrevTxs [] - repeated = [ cases 0 [createCase "k1" 1.0 (bd 1.0)] - , cases 1 [createCase "k1" 3.0 (bd 2.0)] - , cases 2 [createCase "k1" 2.5 (bd $ negate 0.5)] - , cases 3 [createCase "k1" 2.5 (bd 0.0)] - , cases 4 [createCase "k1" 6.0 (bd 3.5)] - ] - in test "same key, different txs, not previously seen" noPrevLogs repeated - - case5 = - let prevLogs = mockPrevTxs [("k1", 10.0)] - repeated = [ cases 0 [ createCase "k1" 9.99 (bd $ negate 0.01) - , createCase "k1" 9.0 (bd $ negate 0.99) - , createCase "k1" 9.5 (bd 0.5) ] - , cases 1 [ createCase "k1" 1.0 (bd $ negate 8.5) - , createCase "k1" 5.0 (bd 4.0) - , createCase "k1" 4.5 (bd $ negate 0.5) - , createCase "k1" 4.55 (bd 0.05) ] - , cases 2 [ createCase "k1" 4.0 (bd $ negate 0.55) ] - ] - in test "same key, different and same txs, previously seen" prevLogs repeated - - case6 = - let prevLogs = mockPrevTxs [("miner", 10.0), ("sender1", 10.0), ("sender2", 10.0)] - mock = [ cases 0 [createCase "miner" 12.0 (bd 2.0)] - -------------------------------------------------------- - , cases 1 [ createCase "sender1" 8.0 (bd $ negate 2.0)] - , cases 2 [ createCase "sender1" 9.0 (bd 1.0) - , createCase "miner" 13.0 (bd 1.0)] - -------------------------------------------------------- - , cases 3 [ createCase "sender1" 7.0 (bd $ negate 2.0)] - , cases 4 [ createCase "sender1" 5.0 (bd $ negate 2.0) -- transfer - , createCase "sender2" 12.0 (bd 2.0)] -- transfer - , cases 5 [ createCase "sender1" 6.0 (bd 1.0) - , createCase "miner" 14.0 (bd 1.0)] - -------------------------------------------------------- - , cases 6 [ createCase "sender2" 10.0 (bd $ negate 2.0)] - , cases 7 [ createCase "sender2" 9.5 (bd $ negate 0.5) -- transfer - , createCase "sender1" 6.5 (bd 0.5)] -- transfer - , cases 8 [ createCase "sender2" 10.5 (bd 1.0) - , createCase "miner" 15.0 (bd 1.0)] - -------------------------------------------------------- - , cases 9 [ createCase "sender1" 4.5 (bd $ negate 2.0)] - , cases 10 [ createCase "sender1" 5.5 (bd 1.0) - , createCase "miner" 16.0 (bd 1.0)] - ] - in test "simulate actual block, previously seen transactions" prevLogs mock - - - mockPrevTxs :: [(T.Text, Decimal)] -> Map RowKey AccountRow - mockPrevTxs txs = M.fromList $ map f txs - where - f (key, bal) = (RowKey key, mockAcctRow key bal) - - createCase - :: T.Text - -> Decimal - -> BalanceDelta - -> (AccountRow, AccountLog) - createCase key endingBal delta = - let g = mockGuard key - acctRow = (key, endingBal, g) - acctLog = AccountLog key delta g g - in (acctRow, acctLog) - - cases - :: Word64 - -> [(AccountRow, AccountLog)] - -> (TxId, [(AccountRow, AccountLog)]) - cases i rows = (TxId i, rows) - - test - :: String - -> Map RowKey AccountRow - -> [(TxId, [(AccountRow, AccountLog)])] - -> Assertion - test label prevBals cs = - let justAcctRows (tid, rows) = (tid, map fst rows) - justAcctLogs (tid, rows) = (tid, map snd rows) - hist = M.fromList $! map justAcctRows cs - actuals = getBalanceDeltas hist prevBals - expects = M.fromList $! map justAcctLogs cs - in assertEqualMap label assertEqualAcctLog expects actuals - - -matchNonGenesisBlockTransactionsToLogs :: Assertion -matchNonGenesisBlockTransactionsToLogs = do - testNonGenesisBlock "Match all txs in a non-genesis block" cases - where - cases = - [ MatchRosettaTx - { _matchRosettaTx_caseLabel = "Coinbase Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey0" - , _matchRosettaTx_result = TxSuccess (TxId 0) - , _matchRosettaTx_operations = - [ mops (TxId 0) [ mop CoinbaseReward (opId 0) [] ] ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Non-Coin Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey1" - , _matchRosettaTx_result = TxSuccess (TxId 2) - , _matchRosettaTx_operations = - [ mops (TxId 1) [ mop FundTx (opId 0) [] ] - , mops (TxId 3) [ mop GasPayment (opId 1) [opId 0] - , mop GasPayment (opId 2) [opId 0, opId 1] ] - ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Another Non-Coin Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey2" - , _matchRosettaTx_result = TxSuccess (TxId 5) - , _matchRosettaTx_operations = - [ mops (TxId 4) [ mop FundTx (opId 0) [] ] - , mops (TxId 6) [ mop GasPayment (opId 1) [opId 0] - , mop GasPayment (opId 2) [opId 0, opId 1] ] - ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Coin Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey3" - , _matchRosettaTx_result = TxSuccess (TxId 8) - , _matchRosettaTx_operations = - [ mops (TxId 7) [ mop FundTx (opId 0) [] ] - , mops (TxId 8) [ mop TransferOrCreateAcct (opId 1) [] - , mop TransferOrCreateAcct (opId 2) [opId 1] ] - , mops (TxId 9) [ mop GasPayment (opId 3) [opId 0] - , mop GasPayment (opId 4) [opId 0, opId 3] ] - ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Failed Tx" - , _matchRosettaTx_requestKey = "ReqKey4" - , _matchRosettaTx_result = TxFailure - , _matchRosettaTx_operations = - [ mops (TxId 10) [ mop FundTx (opId 0) []] - , mops (TxId 11) [ mop GasPayment (opId 1) [opId 0] ] - ] - } - ] - -matchFailedCoinbaseBlockTransactionsToLogs :: Assertion -matchFailedCoinbaseBlockTransactionsToLogs = do - testNonGenesisBlock "Match all txs in a non-genesis block when coinbase tx failed" failedCoinbaseCases - where - failedCoinbaseCases = - [ MatchRosettaTx - { _matchRosettaTx_caseLabel = "Coinbase Tx, Failed" - , _matchRosettaTx_requestKey = "ReqKey0" - , _matchRosettaTx_result = TxFailure - , _matchRosettaTx_operations = [] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Non-Coin Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey1" - , _matchRosettaTx_result = TxSuccess (TxId 1) - , _matchRosettaTx_operations = - [ mops (TxId 0) [ mop FundTx (opId 0) [] ] - , mops (TxId 2) [ mop GasPayment (opId 1) [opId 0] - , mop GasPayment (opId 2) [opId 0, opId 1] ] - ] - } - ] - -matchNonGenesisSingleTransactionsToLogs :: Assertion -matchNonGenesisSingleTransactionsToLogs = do - [rk1, rk0, rk3, rk2, rk4, missingRk] <- pure $ map run targets - [rk0Exp, rk1Exp, rk2Exp, rk3Exp, rk4Exp] <- pure $ map createExpectedRosettaTx cases - - expectMatch rk0 rk0Exp - expectMatch rk1 rk1Exp - expectMatch rk2 rk2Exp - expectMatch rk3 rk3Exp - expectMatch rk4 rk4Exp - expectMissing "request key should not be present" missingRk - - where - run :: T.Text -> Either String (Maybe Transaction) - run trk = getActual cases f - where f logs cid initial rest = nonGenesisTransaction logs cid initial rest (textToRk trk) - - targets = - [ "ReqKey1", "ReqKey0", "ReqKey3", "ReqKey2", "ReqKey4", "RandomReqKey"] - - expectMatch actual (msg, expect) = - case actual of - Left err -> assertFailure $ adjust msg err - Right Nothing -> assertFailure $ adjust msg - $ adjust "request key missing. Expected request key " - $ show $ _transactionId_hash $ _transaction_transactionId expect - Right (Just actual') -> assertEqualRosettaTx msg (actual', expect) - - expectMissing msg actual = - case actual of - (Right Nothing) -> pure () - Right (Just _) -> assertFailure $ adjust msg "request key NOT missing" - Left err -> assertFailure $ adjust msg err - - cases = - [ MatchRosettaTx - { _matchRosettaTx_caseLabel = "Coinbase Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey0" - , _matchRosettaTx_result = TxSuccess (TxId 0) - , _matchRosettaTx_operations = - [ mops (TxId 0) [ mop CoinbaseReward (opId 0) []] ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Non-Coin Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey1" - , _matchRosettaTx_result = TxSuccess (TxId 2) - , _matchRosettaTx_operations = - [ mops (TxId 1) [ mop FundTx (opId 0) [] ] - , mops (TxId 3) [ mop GasPayment (opId 1) [opId 0] - , mop GasPayment (opId 2) [opId 0, opId 1] ] - ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Another Non-Coin Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey2" - , _matchRosettaTx_result = TxSuccess (TxId 5) - , _matchRosettaTx_operations = - [ mops (TxId 4) [ mop FundTx (opId 0) []] - , mops (TxId 6) [ mop GasPayment (opId 1) [opId 0] - , mop GasPayment (opId 2) [opId 0, opId 1] ] - ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Coin Tx, Successful" - , _matchRosettaTx_requestKey = "ReqKey3" - , _matchRosettaTx_result = TxSuccess (TxId 8) - , _matchRosettaTx_operations = - [ mops (TxId 7) [ mop FundTx (opId 0) [] ] - , mops (TxId 8) [ mop TransferOrCreateAcct (opId 1) [] - , mop TransferOrCreateAcct (opId 2) [opId 1] ] - , mops (TxId 9) [ mop GasPayment (opId 3) [opId 0] - , mop GasPayment (opId 4) [opId 0, opId 3] ] - ] - } - , MatchRosettaTx - { _matchRosettaTx_caseLabel = "Failed Tx" - , _matchRosettaTx_requestKey = "ReqKey4" - , _matchRosettaTx_result = TxFailure - , _matchRosettaTx_operations = - [ mops (TxId 10) [ mop FundTx (opId 0) [] ] - , mops (TxId 11) [ mop GasPayment (opId 1) [opId 0] ] - ] - } - ] - - -checkKDAToRosettaAmount :: Assertion -checkKDAToRosettaAmount = do - assertEqual "normal: 123.0" - (rosettaAmount normalStandard) normalAtomic - assertEqual "min precision: 0.123456789123" - (rosettaAmount smallStandard) smallAtomic - assertEqual "big with min precision: 123456789123.123456789123" - (rosettaAmount bigStandard) bigAtomic - assertEqual "smaller than min precision: 0.123456789123456789" - (rosettaAmount reallySmallStandard) reallySmallAtomic - assertEqual "really big with min precision: 123456789123456789.123456789123" - (rosettaAmount reallyBigStandard) reallyBigAtomic - where - rosettaAmount = _amount_value . kdaToRosettaAmount - - (normalStandard, normalAtomic) = - (123.0, "123000000000000") - (smallStandard, smallAtomic) = - (0.123456789123, "123456789123") - (bigStandard, bigAtomic) = - (123456789123.123456789123, "123456789123123456789123") - (reallySmallStandard, reallySmallAtomic) = - (0.123456789123456789, "123456789123") -- smaller than min precision so will drop extras - (reallyBigStandard, reallyBigAtomic) = - (123456789123456789.123456789123, "123456789123456789123456789123") - -checkValidateNetwork :: Assertion -checkValidateNetwork = do - assertEqual "valid network id" - (run validNetId) (Right "0") - assertEqual "invalid blockchain name" - (run invalidBlockchainName) (Left RosettaInvalidBlockchainName) - assertEqual "mismatched network name" - (run mismatchedNetName) (Left RosettaMismatchNetworkName) - assertEqual "chain id unspecified" - (run chainIdUnspecified) (Left RosettaChainUnspecified) - assertEqual "invalid chain id" - (run invalidChainId) (Left RosettaInvalidChain) - where - run :: (ChainwebVersion, NetworkId) -> Either RosettaFailure T.Text - run (v,net) = either Left (pure . chainIdToText) (validateNetwork v net) - - validNetId = (RecapDevelopment, NetworkId - { _networkId_blockchain = "kadena" - , _networkId_network = "recap-development" - , _networkId_subNetworkId = Just $ SubNetworkId "0" Nothing - }) - invalidBlockchainName = - (fst validNetId, - (snd validNetId) { _networkId_blockchain = "incorrectName" } - ) - mismatchedNetName = (Testnet04, snd validNetId) - chainIdUnspecified = - (fst validNetId, - (snd validNetId) { _networkId_subNetworkId = Nothing } - ) - invalidChainId = - (fst validNetId, - (snd validNetId) { _networkId_subNetworkId = Just $ SubNetworkId "1000" Nothing } - ) - -checkUniqueRosettaErrorCodes :: Assertion -checkUniqueRosettaErrorCodes = case repeated of - Left x -> assertFailure $ "Found a repeated Rosetta Code: " ++ show x - Right _ -> pure () - where - repeated = foldM g S.empty errCodes - g acc x = - if S.member x acc - then Left x - else Right $ S.insert x acc - - errCodes = map (_error_code . rosettaError') [minBound .. maxBound] - -checkTransferCodeInjection :: Assertion -checkTransferCodeInjection = do - assertEqual "Simple AccountIds" - ( fst $ transferCreateCode (accountId "hello") (accountId "world", dummyGuard) dummyAmt) - "(coin.transfer-create \"hello\" \"world\" (read-keyset \"ks\") (read-decimal \"amount\"))" - assertEqual "Simple AccountIds" - ( fst $ transferCreateCode (accountId "hello\")") (accountId "world", dummyGuard) dummyAmt) - "(coin.transfer-create \"hello\\\")\" \"world\" (read-keyset \"ks\") (read-decimal \"amount\"))" - where - dummyGuard = P.mkKeySet [] "any" - dummyAmt = 2.0 - --------------------------------------------------------------------------------- --- Utils - -newtype MockCommandResult = MockCommandResult (Maybe TxId, T.Text) - -instance PendingRosettaTx MockCommandResult where - getSomeTxId (MockCommandResult (tid,_)) = tid - getRequestKey (MockCommandResult (_,rk)) = textToRk rk - makeRosettaTx (MockCommandResult (_,rk)) = mockRosettaTx rk - - -type MatchFunction tx = - Map TxId [AccountLog] - -> ChainId - -> CoinbaseTx MockCommandResult - -> V.Vector MockCommandResult - -> Either String tx - -data TxResultType = TxSuccess TxId | TxFailure - -data MatchOperation = MatchOperation - { _matchOperation_accountLog :: AccountLog - , _matchOperation_expectedOpType :: OperationType - , _matchOperation_expectedOpIdx :: OperationId - , _matchOperation_expectedRelatedOpIds :: [OperationId] - } - --- | Helper function that provides a random AccountLog. --- This is helpful when testing tx-log matching don't --- care about the actual contents of AccountLog. -mop - :: OperationType - -> OperationId - -> [OperationId] - -> MatchOperation -mop = MatchOperation acctLog - where - key = "someKey" -- dummy variable - delta = bd $ negate 1.0 -- dummy variable - g = mockGuard key - acctLog = AccountLog key delta g g - -data MatchOperations = MatchOperations - { _matchOperations_txId :: TxId - , _matchOperations_operations :: [MatchOperation] - } - -mops :: TxId -> [MatchOperation] -> MatchOperations -mops = MatchOperations - -data MatchRosettaTx = MatchRosettaTx - { _matchRosettaTx_caseLabel :: String - , _matchRosettaTx_requestKey :: T.Text - , _matchRosettaTx_result :: TxResultType - , _matchRosettaTx_operations :: [MatchOperations] - } - - -createMockCmdResults :: [MatchRosettaTx] -> [MockCommandResult] -createMockCmdResults = map f - where - f (MatchRosettaTx _ rk (TxSuccess tid) _) = MockCommandResult (Just tid, rk) - f (MatchRosettaTx _ rk TxFailure _) = MockCommandResult (Nothing, rk) - -createLogsMap :: [MatchRosettaTx] -> Map TxId [AccountLog] -createLogsMap cases = M.fromList $! concat $! map (map f . _matchRosettaTx_operations) cases - where - f (MatchOperations tid ops) = (tid, map _matchOperation_accountLog ops) - -createOperations :: [MatchOperations] -> [Operation] -createOperations opsCases = concat $! map f opsCases - where - f (MatchOperations _ ops) = map createOperation ops - - opIdx = _operationId_index - - createOperation (MatchOperation acctLog otype oid related) = - operation Successful otype acctLog (opIdx oid) related - -createExpectedRosettaTx :: MatchRosettaTx -> (String, Transaction) -createExpectedRosettaTx m = (msg, mockRosettaTx rk cid ops) - where - rk = _matchRosettaTx_requestKey m - msg = _matchRosettaTx_caseLabel m - ops = createOperations (_matchRosettaTx_operations m) - cid = unsafeChainId 0 - - -getActual :: [MatchRosettaTx] -> MatchFunction tx -> Either String tx -getActual cases f = - case createMockCmdResults cases of - coinbaseResult:restResults -> f logs cid coinbaseResult (V.fromList $! restResults) - _ -> Left "Missing coinbase case" - where - logs = createLogsMap cases - cid = unsafeChainId 0 - -testNonGenesisBlock :: String -> [MatchRosettaTx] -> Assertion -testNonGenesisBlock msg cases = do - case getActual cases nonGenesisTransactions of - Left err -> assertFailure err - Right actuals -> do - assertEqual (adjust msg "list should be same length") (length actuals) (length expects) - mapM_ f (zip actuals expects) - where - expects = map createExpectedRosettaTx cases - f (actualTx, (txMsg, expectTx)) = - assertEqualRosettaTx (adjust msg txMsg) (actualTx, expectTx) - - -mockAcctRow :: T.Text -> Decimal -> AccountRow -mockAcctRow key bal = - (key, bal, mockGuard key) - -mockGuard :: T.Text -> Value -mockGuard key = toJSON (key <> "PublicKey") - -bd :: Decimal -> BalanceDelta -bd = BalanceDelta - -opId :: Word64 -> OperationId -opId i = OperationId i Nothing - -assertEqualAcctLog - :: String - -> (AccountLog, AccountLog) - -> Assertion -assertEqualAcctLog msg (log1, log2) = do - assertEqual (adjust msg "same key") key1 key2 - assertEqual (adjust msg "same balanceDelta") balDelta1 balDelta2 - assertEqual (adjust msg "same currGuard") currGuard1 currGuard2 - assertEqual (adjust msg "same prevGuard") prevGuard1 prevGuard2 - where - AccountLog key1 balDelta1 currGuard1 prevGuard1 = log1 - AccountLog key2 balDelta2 currGuard2 prevGuard2 = log2 - -assertSameOperation - :: String - -> (Operation, Operation) - -> Assertion -assertSameOperation msg (op1, op2) = do - assertEqual (adjust msg "same operation id") oid1 oid2 - assertEqual (adjust msg' "same operation metadata") meta1 meta2 - assertEqual (adjust msg' "same related operations") rops1 rops2 - assertEqual (adjust msg' "same operation type") otype1 otype2 - assertEqual (adjust msg' "same operation status") ostatus1 ostatus2 - assertEqual (adjust msg' "same operation account") acct1 acct2 - assertEqual (adjust msg' "same operation amount") amt1 amt2 - assertEqual (adjust msg' "same operation coinChange") coin1 coin2 - where - msg' = adjust msg $ "operationId=" ++ show (_operationId_index oid1) - Operation oid1 rops1 otype1 ostatus1 acct1 amt1 coin1 meta1 = op1 - Operation oid2 rops2 otype2 ostatus2 acct2 amt2 coin2 meta2 = op2 - -assertEqualRosettaTx - :: String - -> (Transaction, Transaction) - -> Assertion -assertEqualRosettaTx msg (tx1, tx2) = do - assertEqual (adjust msg "same transactionId") tid1 tid2 - mapM_ (assertSameOperation (adjust msg' "same operations")) (zip ops1 ops2) - assertEqual (adjust msg' "same metadata") meta1 meta2 - where - msg' = adjust msg $ "transactionId=" ++ show (_transactionId_hash tid1) - Transaction tid1 ops1 meta1 = tx1 - Transaction tid2 ops2 meta2 = tx2 - -assertEqualList - :: String - -> (String -> (a,a) -> Assertion) - -> [a] - -> [a] - -> Assertion -assertEqualList msg f li1 li2 = do - assertEqual (msg ++ ": lists should be the same size") (length li1) (length li2) - mapM_ (f msg) (zip li1 li2) - -assertEqualMap - :: (Eq a, Ord a, Show a, Eq b, Show b) - => String - -> (String -> (b,b) -> Assertion) - -> Map a [b] - -> Map a [b] - -> Assertion -assertEqualMap msg liF m1 m2 = do - assertEqual (msg ++ ": maps should be the same size") (M.size m1) (M.size m2) - void $ M.traverseWithKey f m1 - where - f tid e1 = - let msg' = (msg ++ ": key=" ++ show tid) - in case M.lookup tid m2 of - Nothing -> assertFailure $ msg' ++ ": second map didn't have key" - Just e2 -> assertEqualList msg' liF e1 e2 - -mockRosettaTx :: T.Text -> ChainId -> [Operation] -> Transaction -mockRosettaTx mrk _ ops = - Transaction - { _transaction_transactionId = TransactionId mrk - , _transaction_operations = ops - , _transaction_metadata = Nothing - } - -textToRk :: T.Text -> RequestKey -textToRk = RequestKey . Hash . BS.toShort . T.encodeUtf8 - -adjust :: String -> String -> String -adjust msg a = msg ++ ": " ++ show a diff --git a/test/unit/Chainweb/Test/Rosetta/RestAPI.hs b/test/unit/Chainweb/Test/Rosetta/RestAPI.hs deleted file mode 100644 index ee43bd1cb9..0000000000 --- a/test/unit/Chainweb/Test/Rosetta/RestAPI.hs +++ /dev/null @@ -1,835 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE LambdaCase #-} - -module Chainweb.Test.Rosetta.RestAPI -( tests -) where - -import Control.Concurrent.Async -import Control.Concurrent.MVar -import Control.Lens -import Control.Monad.IO.Class - -import qualified Data.Aeson as A -import qualified Data.Aeson.KeyMap as KM -import Data.Decimal -import Data.Functor (void) -import qualified Data.HashMap.Strict as HM -import Data.IORef -import qualified Data.List.NonEmpty as NEL -import Data.Text (Text) -import Data.Foldable - -import GHC.Natural -import GHC.Word - -import Servant.Client - -import Test.Tasty -import Test.Tasty.HUnit - --- internal pact modules - -import Pact.Types.API -import Pact.Types.Command - --- internal chainweb modules - -import Chainweb.BlockHeight -import Chainweb.Chainweb.Configuration -import Chainweb.Graph -import Chainweb.Pact.Utils (aeson) -import qualified Chainweb.Pact.Transactions.OtherTransactions as Other -import qualified Chainweb.Pact.Transactions.CoinV3Transactions as CoinV3 -import qualified Chainweb.Pact.Transactions.MainnetKADTransactions as MNKAD -import Chainweb.Rosetta.Utils -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.RestAPI.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time (Time(..), Micros(..), getCurrentTimeIntegral) -import Chainweb.Utils -import Chainweb.Version - -import Chainweb.Storage.Table.RocksDB - -import Rosetta - -import System.IO.Unsafe (unsafePerformIO) -import Chainweb.Rosetta.RestAPI.Client (rosettaConstructionDeriveApiClient) - - --- -------------------------------------------------------------------------- -- --- Global Settings - -v :: ChainwebVersion -v = fastForkingCpmTestVersion petersonChainGraph - -nodes :: Word -nodes = 1 - -cid :: ChainId -cid = unsafeChainId 0 - -cids :: [Text] -cids = chainIds v ^.. folded . to chainIdInt . to (sshow @Int) - -nonceRef :: IORef Natural -nonceRef = unsafePerformIO $ newIORef 0 -{-# NOINLINE nonceRef #-} - -defGasLimit, defGasPrice :: Decimal -defGasLimit = realToFrac $ _cbGasLimit defaultCmd -defGasPrice = realToFrac $ _cbGasPrice defaultCmd - -defFundGas :: Decimal -defFundGas = defGasLimit * defGasPrice - -gasCost :: Integer -> Decimal -gasCost units = realToFrac units * defGasPrice - -defMiningReward :: Decimal -defMiningReward = 2.304523 - -transferGasCost :: Decimal -transferGasCost = gasCost 698 - -type RosettaTest = IO (Time Micros) -> IO ClientEnv -> TestTree - --- -------------------------------------------------------------------------- -- --- Test Tree - -tests :: RocksDb -> TestTree -tests rdb = testGroup "Chainweb.Test.Rosetta.RestAPI" - [ rosettaTests rdb - , constructionApiTests rdb - ] - --- -------------------------------------------------------------------------- -- --- General Rosetta Tests (construction API disabled) - -rosettaTests :: RocksDb -> TestTree -rosettaTests rdb = - withResourceT (withNodeDbDirs rdb nodes) $ \dbdirs -> - withResourceT (withNodesAtLatestBehavior v mkConfig =<< liftIO dbdirs) $ \envIo -> - withResource' getCurrentTimeIntegral $ \tio -> - independentSequentialTestGroup "Rosetta Api tests" $ - tgroup tio $ _getServiceClientEnv <$> envIo - where - mkConfig = configRosetta .~ True - - -- Not supported: - -- - -- * Mempool Transaction: cant test reasonably without DOS'ing the mempool - -- * Construction Metadata: N/A - -- - -- Note: - -- - -- * Tests run in sequence, but still interact with each other because - -- confirmation depths are not validated for each tx. Checking account - -- balances between two different tests is futile. - -- - - tgroup tio envIo = fmap (\test -> test tio envIo) - [ blockTransactionTests - , blockCoinV2RemediationTests - , block20ChainRemediationTests - , blockTests "Block Test without potential remediation" - , accountBalanceTests - , mempoolTests - , networkListTests - , networkOptionsTests - , networkStatusTests - , blockKAccountAfterPact42 - , blockCoinV3RemediationTests - , constructionApiDeprecationTest - ] - --- | Rosetta account balance endpoint tests --- -accountBalanceTests :: RosettaTest -accountBalanceTests tio envIo = - testCaseSteps "Account Balance Tests" $ \step -> do - step "check initial balance" - cenv <- envIo - resp0 <- accountBalance v cenv req - let startBal = 99999997.8604 - checkBalance resp0 startBal - - step "send 1.0 tokens to sender00 from sender01" - void $! transferOneAsync_ cid tio cenv (void . return) - - step "check post-transfer and gas fees balance" - resp1 <- accountBalance v cenv req - checkBalance resp1 (startBal - transferGasCost - 1) - where - req = AccountBalanceReq nid (AccountId "sender00" Nothing Nothing) Nothing - - checkBalance :: HasCallStack => AccountBalanceResp -> Decimal -> IO () - checkBalance resp bal1 = do - let b0 = head $ _accountBalanceResp_balances resp - b1 = kdaToRosettaAmount bal1 - curr = _amount_currency b0 - - b1 @=? b0 - curr @=? kda - --- | Test that /block endpoint does not return a --- TxLog parse error after fork to Pact 420. --- This assumes that this test occurs after the --- fork blockheight. -blockKAccountAfterPact42 :: RosettaTest -blockKAccountAfterPact42 tio envIo = - testCaseSteps "Block k Account After Pact 420 Test" $ \step -> do - cenv <- envIo - rkmv <- newEmptyMVar @RequestKeys - - step "send transaction" - prs <- mkOneKCoinAccountAsync cid tio cenv (putMVar rkmv) - rk <- NEL.head . _rkRequestKeys <$> takeMVar rkmv - cmdMeta <- KM.toMap <$> extractMetadata rk prs - bh <- cmdMeta ^?! mix "blockHeight" - - step "check that block endpoint doesn't return TxLog parse error" - _ <- block v cenv (req bh) - pure () - where - req h = BlockReq nid $ PartialBlockId (Just h) Nothing - --- | Rosetta block transaction endpoint tests --- -blockTransactionTests :: RosettaTest -blockTransactionTests tio envIo = - testCaseSteps "Block Transaction Tests" $ \step -> do - cenv <- envIo - rkmv <- newEmptyMVar @RequestKeys - - step "send 1.0 from sender00 to sender01 and extract block tx request" - prs <- transferOneAsync cid tio cenv (putMVar rkmv) - req <- mkTxReq rkmv prs - - step "send in block tx request" - resp <- blockTransaction v cenv req - - (fundtx,deb,cred,redeem,reward) <- - case _transaction_operations $ _blockTransactionResp_transaction resp of - [a,b,c,d,e] -> return (a,b,c,d,e) - _ -> assertFailure "transfer should have resulted in 5 transactions" - - -- The order in which operations are returned is flaky and may break. Use - -- the following to double check the order in case this test fails. - -- - -- print "fundtx: ----------------------" - -- print fundtx - -- print "cred: ----------------------" - -- print cred - -- print "deb: ----------------------" - -- print deb - -- print "redeem: ----------------------" - -- print redeem - -- print "reward: ----------------------" - -- print reward - -- print "----------------------" - - - step "validate initial gas buy at op index 0" - validateOp 0 "FundTx" sender00ks Successful (negate defFundGas) fundtx - - step "validate sender00 debit at op index 1" - validateOp 1 "TransferOrCreateAcct" sender00ks Successful (negate 1.0) deb - - step "validate sender01 credit at op index 2" - validateOp 2 "TransferOrCreateAcct" sender01ks Successful 1.0 cred - - step "validate sender00 gas redemption at op index 3" - validateOp 3 "GasPayment" sender00ks Successful (defFundGas - transferGasCost) redeem - - step "validate miner gas reward at op index 4" - validateOp 4 "GasPayment" noMinerks Successful transferGasCost reward - - where - mkTxReq rkmv prs = do - rk <- NEL.head . _rkRequestKeys <$> takeMVar rkmv - meta <- KM.toMap <$> extractMetadata rk prs - bh <- meta ^?! mix "blockHeight" - bhash <- meta ^?! mix "blockHash" - - let bid = BlockId bh bhash - tid = rkToTransactionId rk - - return $ BlockTransactionReq nid bid tid - - --- | Rosetta block endpoint tests --- --- TODO: investigate --- Attempt to buy gas failed with: : Failure: Tx Failed: read: row not found: sender00 -blockTests :: String -> RosettaTest -blockTests testname tio envIo = testCaseSteps testname $ \step -> do - cenv <- envIo - rkmv <- newEmptyMVar @RequestKeys - - step "fetch genesis block" - (BlockResp (Just bl0) _) <- block v cenv (req 0) - _block_blockId bl0 @?= genesisId - - step "send transaction" - prs <- transferOneAsync cid tio cenv (putMVar rkmv) - rk <- NEL.head . _rkRequestKeys <$> takeMVar rkmv - cmdMeta <- KM.toMap <$> extractMetadata rk prs - bh <- cmdMeta ^?! mix "blockHeight" - - step "check tx at block height matches sent tx + remediations" - resp1 <- block v cenv (req bh) - validateTransferResp bh resp1 - where - req h = BlockReq nid $ PartialBlockId (Just h) Nothing - - validateTransferResp bh resp = do - _blockResp_otherTransactions resp @?= Nothing - - let validateBlock someBlock = do - Just b <- pure someBlock - _block_metadata b @?= Nothing - _blockId_index (_block_blockId b) @?= bh - _blockId_index (_block_parentBlockId b) @?= (bh - 1) - - case _block_transactions b of - [x,y] -> do - -- not a remediation block - let ops = _transaction_operations x <> _transaction_operations y - case ops of - [a,b',c,d,e,f] -> validateTxs Nothing a b' c d e f - _ -> assertFailure "should have 6 ops: coinbase + 5 for transfer tx" - - _ -> assertFailure "block should have at least 2 transactions: coinbase + txs" - - validateBlock $ _blockResp_block resp - - validateTxs remeds cbase fundtx deb cred gasRedeem gasReward = do - -- The order in which operations are returned is flaky and may break. Use - -- the following to double check the order in case this test fails. - -- - -- step $ "fundtx: ----------------------" - -- step $ debugShowOperation fundtx - -- step $ "deb: ----------------------" - -- step $ debugShowOperation deb - -- step $ "cred: ----------------------" - -- step $ debugShowOperation cred - -- step $ "redeem: ----------------------" - -- step $ debugShowOperation gasRedeem - -- step $ "reward: ----------------------" - -- step $ debugShowOperation gasReward - -- step $ "----------------------" - - -- coinbase is considered a separate tx list - validateOp 0 "CoinbaseReward" noMinerks Successful defMiningReward cbase - - -- 20 chain remediation - case remeds of - Just rem1 -> validateOp 0 "TransferOrCreateAcct" e7f7ks Remediation (negate 100) rem1 - Nothing -> pure () - - -- rest txs (i.e. transfer transaction) - validateOp 0 "FundTx" sender00ks Successful (negate defFundGas) fundtx - validateOp 1 "TransferOrCreateAcct" sender00ks Successful (negate 1.0) deb - validateOp 2 "TransferOrCreateAcct" sender01ks Successful 1.0 cred - validateOp 3 "GasPayment" sender00ks Successful (defFundGas - transferGasCost) gasRedeem - validateOp 4 "GasPayment" noMinerks Successful transferGasCost gasReward - -blockCoinV2RemediationTests :: RosettaTest -blockCoinV2RemediationTests _ envIo = - testCaseSteps "Block CoinV2 Remediation Tests" $ \step -> do - cenv <- envIo - - step "fetch coin v2 remediation block" - resp <- block v cenv (req bhCoinV2Rem) - - step "validate block" - _blockResp_otherTransactions resp @?= Nothing - Just b <- pure $ _blockResp_block resp - _block_metadata b @?= Nothing - _blockId_index (_block_blockId b) @?= bhCoinV2Rem - _blockId_index (_block_parentBlockId b) @?= (bhCoinV2Rem - 1) - - case _block_transactions b of - x:y:z:_ -> do - step "check remediation transactions' request keys" - [ycmd, zcmd] <- return Other.transactions - _transaction_transactionId y @?= pactHashToTransactionId (_cmdHash ycmd) - _transaction_transactionId z @?= pactHashToTransactionId (_cmdHash zcmd) - - step "check remediation transactions' operations" - _transaction_operations y @?= [] -- didn't touch the coin table - _transaction_operations z @?= [] -- didn't touch the coin table - -- NOTE: no remedition withdrawl happens in this version - - step "check coinbase transaction" - [cbase] <- pure $ _transaction_operations x - validateOp 0 "CoinbaseReward" noMinerks Successful defMiningReward cbase - - _ -> assertFailure $ "coin v2 remediation block should have at least 3 transactions:" - ++ " coinbase + 2 remediations" - where - bhCoinV2Rem = v ^?! versionForks . at CoinV2 . _Just . atChain cid . _ForkAtBlockHeight . to getBlockHeight - req h = BlockReq nid $ PartialBlockId (Just h) Nothing - -block20ChainRemediationTests :: RosettaTest -block20ChainRemediationTests _ envIo = - testCaseSteps "Block 20 Chain Remediation Tests" $ \step -> do - cenv <- envIo - - step "fetch remediation block" - resp <- block v cenv (req bhChain20Rem) - - step "validate block" - _blockResp_otherTransactions resp @?= Nothing - Just b <- pure $ _blockResp_block resp - _block_metadata b @?= Nothing - _blockId_index (_block_blockId b) @?= bhChain20Rem - _blockId_index (_block_parentBlockId b) @?= (bhChain20Rem - 1) - - case _block_transactions b of - x:y:_ -> do - step "check remediation transactions' request keys" - [ycmd] <- return MNKAD.transactions - _transaction_transactionId y @?= pactHashToTransactionId (_cmdHash ycmd) - - step "check remediation transactions' operations" - case _transaction_operations x <> _transaction_operations y of - [cbase,remOp] -> do - validateOp 0 "CoinbaseReward" noMinerks Successful defMiningReward cbase - validateOp 0 "TransferOrCreateAcct" e7f7ks Remediation (negate 100) remOp - - _ -> assertFailure "total # of ops should be == 2: coinbase + remediation" - - _ -> assertFailure $ "20 chain remediation block should have at least 2 transactions:" - ++ " coinbase + 1 remediations" - where - bhChain20Rem = 2 - nidChain3 = NetworkId - { _networkId_blockchain = "kadena" - , _networkId_network = "fastfork-CPM-peterson" - , _networkId_subNetworkId = Just (SubNetworkId "3" Nothing) - } - req h = BlockReq nidChain3 $ PartialBlockId (Just h) Nothing - -blockCoinV3RemediationTests :: RosettaTest -blockCoinV3RemediationTests _ envIo = - testCaseSteps "Block CoinV3 Remediation Tests" $ \step -> do - cenv <- envIo - - step "fetch coin v3 remediation block" - resp <- block v cenv (req bhCoinV3Rem) - - step "validate block" - _blockResp_otherTransactions resp @?= Nothing - Just b <- pure $ _blockResp_block resp - _block_metadata b @?= Nothing - _blockId_index (_block_blockId b) @?= bhCoinV3Rem - _blockId_index (_block_parentBlockId b) @?= (bhCoinV3Rem - 1) - - case _block_transactions b of - x:y:_ -> do - step "check remediation transactions' request keys" - [ycmd] <- return CoinV3.transactions - _transaction_transactionId y @?= pactHashToTransactionId (_cmdHash ycmd) - - step "check remediation transactions' operations" - _transaction_operations y @?= [] -- didn't touch the coin table - -- NOTE: no remedition withdrawl happens in this version - - step "check coinbase transaction" - [cbase] <- pure $ _transaction_operations x - validateOp 0 "CoinbaseReward" noMinerks Successful defMiningReward cbase - - _ -> assertFailure $ "coin v3 remediation block should have at least 3 transactions:" - ++ " coinbase + 2 remediations" - where - bhCoinV3Rem = v ^?! versionForks . at Pact4Coin3 . _Just . atChain cid . _ForkAtBlockHeight . to getBlockHeight - req h = BlockReq nid $ PartialBlockId (Just h) Nothing - --- | Rosetta mempool endpoint tests --- -mempoolTests :: RosettaTest -mempoolTests tio envIo = testCaseSteps "Mempool Tests" $ \step -> do - cenv <- envIo - rkmv <- newEmptyMVar @RequestKeys - - step "execute transfer and wait on mempool data" - void $! async $ transferOneAsync_ cid tio cenv (putMVar rkmv) - rk NEL.:| [] <- _rkRequestKeys <$> takeMVar rkmv - - let tid = rkToTransactionId rk - let test (MempoolResp ts) = return $ elem tid ts - - step "compare requestkey against mempool responses" - void $! repeatUntil test $ mempool v cenv req - where - req = NetworkReq nid Nothing - --- | Rosetta network list endpoint tests --- -networkListTests :: RosettaTest -networkListTests _ envIo = - testCaseSteps "Network List Tests" $ \step -> do - cenv <- envIo - - step "send network list request" - resp <- networkList v cenv req - - for_ (_networkListResp_networkIds resp) $ \n -> do - _networkId_blockchain n @=? "kadena" - _networkId_network n @=? "fastfork-CPM-peterson" - assertBool "chain id of subnetwork is valid" - $ maybe False (\a -> _subNetworkId_network a `elem` cids) - $ _networkId_subNetworkId n - where - req = MetadataReq Nothing - --- | Rosetta network options tests --- -networkOptionsTests :: RosettaTest -networkOptionsTests _ envIo = - testCaseSteps "Network Options Tests" $ \step -> do - cenv <- envIo - - step "send network options request" - resp <- networkOptions v cenv req0 - - let allow = _networkOptionsResp_allow resp - version = _networkOptionsResp_version resp - - step "check options responses against allowable data and versions" - version @=? rosettaVersion - - step "Check that response errors are a subset of valid errors" - respErrors resp @?= rosettaFailures - - step "Check that response statuses are a subset of valid statuses" - _allow_operationStatuses allow @?= operationStatuses - - step "Check that response op types are a subset of op types" - _allow_operationTypes allow @?= operationTypes - where - req0 = NetworkReq nid Nothing - respErrors = _allow_errors . _networkOptionsResp_allow - --- | Rosetta network status tests --- -networkStatusTests :: RosettaTest -networkStatusTests tio envIo = - testCaseSteps "Network Status Tests" $ \step -> do - cenv <- envIo - - step "send network status request" - resp0 <- networkStatus v cenv req - - step "check status response against genesis" - genesisId @=? _networkStatusResp_genesisBlockId resp0 - - step "send in a transaction and update current block" - transferOneAsync_ cid tio cenv (void . return) - resp1 <- networkStatus v cenv req - - step "check status response genesis and block height" - genesisId @=? _networkStatusResp_genesisBlockId resp1 - (blockIdOf resp1 > blockIdOf resp0) @? "current block id heights must increment" - where - req = NetworkReq nid Nothing - - blockIdOf = _blockId_index . _networkStatusResp_currentBlockId - --- | Test proper deprecation message when construction API is disabled --- -constructionApiDeprecationTest :: RosettaTest -constructionApiDeprecationTest _ envIo = - testCaseSteps "Calling disabled construction Api results in failure" $ \step -> do - cenv <- envIo - step "rosetta API is enabled and ready to be used" - assertRosettaApi cenv - step "call construction API endpoint" - void $ callConstrunctionApi cenv >>= \case - Left (FailureResponse _ (Response { responseBody = x})) -> - case A.eitherDecode @(HM.HashMap String A.Value) x of - Left e -> assertFailure $ "decoding of response failed: " <> e - Right y -> case HM.lookup "code" y of - Nothing -> assertFailure "decoding of response failed" - Just c -> assertEqual "failure code is 35" (A.Number 35) c - Left e -> assertFailure $ "unexpected failure: " <> show e - Right t -> assertFailure $ "unexpected success: " <> show t - --- -------------------------------------------------------------------------- -- --- Construction API Tests - --- | The implementation of the construction API is flaky and deprecated. We --- don't provide test coverage for its functionality. We only check whether it --- is enabled when the configuration requests it. --- -constructionApiTests :: RocksDb -> TestTree -constructionApiTests rdb = - withResourceT (withNodeDbDirs rdb nodes) $ \dbdirs -> - withResourceT (withNodesAtLatestBehavior v mkConfig =<< liftIO dbdirs) $ \envIo -> - - testCaseSteps "Construction API available" $ \step -> do - cenv <- _getServiceClientEnv <$> envIo - step "General Rosetta API is enabled and ready to be used" - assertRosettaApi cenv - - step "call construction API endpoint" - void $ callConstrunctionApi cenv >>= \case - Right _ -> return () - Left e -> assertFailure $ show e - where - mkConfig = (configRosetta .~ True) . (configRosettaConstructionApi .~ True) - -callConstrunctionApi :: ClientEnv -> IO (Either ClientError ConstructionDeriveResp) -callConstrunctionApi = runClientM (rosettaConstructionDeriveApiClient v req) - where - netId = nid { _networkId_subNetworkId = Just (SubNetworkId (chainIdToText cid) Nothing) } - rosettaPubKeySender01 = RosettaPublicKey (fst sender01) CurveEdwards25519 - req = ConstructionDeriveReq netId rosettaPubKeySender01 Nothing - --- ------------------------------------------------------------------ -- --- Test Data - -kda :: Currency -kda = Currency "KDA" 12 Nothing - -nid :: NetworkId -nid = NetworkId - { _networkId_blockchain = "kadena" - , _networkId_network = "fastfork-CPM-peterson" - , _networkId_subNetworkId = Just (SubNetworkId (chainIdToText cid) Nothing) - } - -genesisId :: BlockId -genesisId = BlockId 0 "dqdUQNqEXcdMDeb6xWXuv1_KvLvDXysgsaEU8ZfLs9Q" - -rosettaVersion :: RosettaNodeVersion -rosettaVersion = RosettaNodeVersion - { _version_rosettaVersion = "1.4.4" - , _version_nodeVersion = VERSION_chainweb - , _version_middlewareVersion = Nothing - , _version_metadata = Just $ KM.fromList - [ "node-api-version" A..= ("0.0" :: Text) - , "chainweb-version" A..= ("fastfork-CPM-peterson" :: Text) - , "rosetta-chainweb-version" A..= ("2.0.0" :: Text) - ] - } - -rosettaFailures :: [RosettaError] -rosettaFailures = map (`rosettaError` Nothing) (enumFrom RosettaChainUnspecified) - -operationStatuses :: [OperationStatus] -operationStatuses = - [ OperationStatus "Successful" True - , OperationStatus "Remediation" True - ] - -operationTypes :: [Text] -operationTypes = - [ "CoinbaseReward" - , "FundTx" - , "GasPayment" - , "TransferOrCreateAcct" - ] - --- | Validate all useful data for a tx operation --- -validateOp - :: Word64 - -- ^ op idx - -> Text - -- ^ operation type - -> TestKeySet - -- ^ operation keyset - -> ChainwebOperationStatus - -- ^ operation status - -> Decimal - -- ^ operation balance delta - -- (how balance increased or decreased in given operation) - -> Operation - -- ^ the op - -> Assertion -validateOp idx opType ks st bal o = do - _operation_operationId o @?= OperationId idx Nothing - _operation_type o @?= opType - _operation_status o @?= sshow st - _operation_account o @?= Just (AccountId acct Nothing acctMeta) - _operation_amount o @?= Just balRosettaAmt - where - balRosettaAmt = kdaToRosettaAmount bal - acct = _testKeySet_name ks - _publicKeys = case _testKeySet_key ks of - Nothing -> [] - Just k -> [fst k] - _pred' = _testKeySet_pred ks - acctMeta = Nothing - --- ------------------------------------------------------------------ -- --- Test Pact Cmds - --- | Build a simple transfer from sender00 to sender01 --- -mkTransfer :: ChainId -> IO (Time Micros) -> IO SubmitBatch -mkTransfer sid tio = do - t <- toTxCreationTime <$> tio - n <- readIORef nonceRef - c <- buildTextCmd ("nonce-transfer-" <> sshow t <> "-" <> sshow n) v - $ set cbSigners - [ mkEd25519Signer' sender00 - [ mkTransferCap "sender00" "sender01" 1.0 - , mkGasCap - ] - ] - $ set cbCreationTime t - $ set cbChainId sid - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - - modifyIORef' nonceRef (+1) - return $ SubmitBatch (pure c) - -mkKCoinAccount :: ChainId -> IO (Time Micros) -> IO SubmitBatch -mkKCoinAccount sid tio = do - let kAcct = "k:" <> fst sender00 - t <- toTxCreationTime <$> tio - n <- readIORef nonceRef - c <- buildTextCmd ("nonce-transfer-" <> sshow t <> "-" <> sshow n) v - $ set cbSigners - [ mkEd25519Signer' sender00 - [ mkTransferCap "sender00" kAcct 20.0 - , mkGasCap ] - ] - $ set cbCreationTime t - $ set cbChainId sid - $ set cbRPC - (mkExec ("(coin.transfer-create \"sender00\" \"" <> kAcct <> "\" (read-keyset \"sender00\") 20.0)") - (mkKeySetData "sender00" [sender00])) - - $ defaultCmd - - modifyIORef' nonceRef (+1) - return $ SubmitBatch (pure c) - -mkOneKCoinAccountAsync - :: ChainId - -> IO (Time Micros) - -> ClientEnv - -> (RequestKeys -> IO ()) - -> IO PollResponses -mkOneKCoinAccountAsync sid tio cenv callback = do - batch0 <- mkKCoinAccount sid tio - void $! callback (f batch0) - rks <- sending v cid cenv batch0 - polling v cid cenv rks ExpectPactResult - where - f (SubmitBatch cs) = RequestKeys (cmdToRequestKey <$> cs) - --- | Transfer one token from sender00 to sender01, applying some callback to --- the command batch before sending. --- -transferOneAsync - :: ChainId - -> IO (Time Micros) - -> ClientEnv - -> (RequestKeys -> IO ()) - -> IO PollResponses -transferOneAsync sid tio cenv callback = do - batch0 <- mkTransfer sid tio - void $! callback (f batch0) - rks <- sending v cid cenv batch0 - polling v cid cenv rks ExpectPactResult - where - f (SubmitBatch cs) = RequestKeys (cmdToRequestKey <$> cs) - --- | Transfer one token from sender00 to sender01 asynchronously applying some --- callback (usually putting the requestkeys into some 'MVar'), and forgetting --- the poll response results. We use this when we want to just execute and poll --- and do not need the responses. --- -transferOneAsync_ - :: ChainId - -> IO (Time Micros) - -> ClientEnv - -> (RequestKeys -> IO ()) - -> IO () -transferOneAsync_ sid tio cenv callback - = void $! transferOneAsync sid tio cenv callback - --- ------------------------------------------------------------------ -- --- Utils - --- | Extract poll response metadata at some request key --- -extractMetadata :: RequestKey -> PollResponses -> IO (KM.KeyMap A.Value) -extractMetadata rk (PollResponses pr) = case HM.lookup rk pr of - Just cr -> case _crMetaData cr of - Just (A.Object o) -> return o - _ -> assertFailure "impossible: empty metadata" - _ -> assertFailure "test transfer did not succeed" - --- | A composition of an index into a k-v structure with aeson values --- and conversion to non-JSONified structured, asserting test failure if --- it fails to decode as the give type @a@. --- -mix - :: forall a m - . ( A.FromJSON a - , Ixed m - , IxValue m ~ A.Value - ) - => Index m - -> Fold m (IO a) -mix i = ix i . to A.fromJSON . to (aeson assertFailure return) - -assertRosettaApi :: ClientEnv -> IO () -assertRosettaApi cenv = do - resp <- networkStatus v cenv (NetworkReq nid Nothing) - genesisId @=? _networkStatusResp_genesisBlockId resp - --- ------------------------------------------------------------------ -- --- Key Sets - -data TestKeySet = TestKeySet - { _testKeySet_name :: !Text - , _testKeySet_key :: !(Maybe SimpleKeyPair) - , _testKeySet_pred :: !Text - } - -e7f7ks :: TestKeySet -e7f7ks = TestKeySet - { _testKeySet_name = "e7f7634e925541f368b827ad5c72421905100f6205285a78c19d7b4a38711805" - , _testKeySet_key = Just ("e7f7634e925541f368b827ad5c72421905100f6205285a78c19d7b4a38711805" - , "") -- Never used for signing - , _testKeySet_pred = "keys-all" - } - -noMinerks :: TestKeySet -noMinerks = TestKeySet - { _testKeySet_name = "NoMiner" - , _testKeySet_key = Nothing - , _testKeySet_pred = "<" - } - -sender00ks :: TestKeySet -sender00ks = TestKeySet - { _testKeySet_name = "sender00" - , _testKeySet_key = Just sender00 - , _testKeySet_pred = "keys-all" - } - -sender01ks :: TestKeySet -sender01ks = TestKeySet - { _testKeySet_name = "sender01" - , _testKeySet_key = Just sender01 - , _testKeySet_pred = "keys-all" - } diff --git a/test/unit/ChainwebTests.hs b/test/unit/ChainwebTests.hs index 4eed5ccbf1..8e729e3730 100644 --- a/test/unit/ChainwebTests.hs +++ b/test/unit/ChainwebTests.hs @@ -78,8 +78,6 @@ import qualified Chainweb.Test.Pact5.RemotePactTest import qualified Chainweb.Test.Pact5.SPVTest import qualified Chainweb.Test.Pact5.TransactionExecTest import qualified Chainweb.Test.RestAPI (tests) -import qualified Chainweb.Test.Rosetta (tests) -import qualified Chainweb.Test.Rosetta.RestAPI (tests) import qualified Chainweb.Test.Roundtrips (tests) import qualified Chainweb.Test.SPV (tests) import qualified Chainweb.Test.SPV.EventProof (properties) @@ -142,8 +140,7 @@ pactTestSuite rdb = testGroup "Chainweb-Pact Tests" nodeTestSuite :: RocksDb -> TestTree nodeTestSuite rdb = independentSequentialTestGroup "Tests starting nodes" - [ Chainweb.Test.Rosetta.RestAPI.tests rdb - , Chainweb.Test.Pact4.RemotePactTest.tests rdb -- BROKEN + [ Chainweb.Test.Pact4.RemotePactTest.tests rdb -- BROKEN ] suite :: RocksDb -> [TestTree] @@ -165,7 +162,6 @@ suite rdb = , Chainweb.Test.Pact5.SPVTest.tests rdb , Chainweb.Test.Pact5.RemotePactTest.tests rdb , Chainweb.Test.Roundtrips.tests - , Chainweb.Test.Rosetta.tests , Chainweb.Test.RestAPI.tests rdb , testGroup "SPV" [ Chainweb.Test.SPV.tests rdb