diff --git a/.gitignore b/.gitignore index aafa48011d..7a8fce3e8f 100644 --- a/.gitignore +++ b/.gitignore @@ -53,3 +53,6 @@ rosetta/logs/* .ghci_history .direnv/ .envrc +parity-* +diffs/ +old-diffs/ diff --git a/cabal.project b/cabal.project index c34ad876dd..cf107b3e47 100644 --- a/cabal.project +++ b/cabal.project @@ -156,6 +156,24 @@ source-repository-package tag: 67c77e68ade204f56d91ad5952fe432188b40d23 --sha256: 0q7nwl56lgic5andc956zv4zipdv5rxjkalm21cxr75r6grkzfmy +source-repository-package + type: git + location: https://github.com/chessai/patience + tag: 2f67d546ea6608fc6ebe5f2f6976503cbf340442 + --sha256: 0x137akvbh4kr3qagksw74xdj2xz5vjnx1fbr41bb54a0lkcb8mm + +source-repository-package + type: git + location: https://github.com/andrewthad/chronos + tag: b199bf6df1453af95832c2d2f9f0ef48c3622caa + --sha256: 056awkmdmkqdd5g3m8a1ibg2vp02kbppmidkfh4aildb1brq970a + +source-repository-package + type: git + location: https://gitlab.com/edmundnoble/predicate-transformers + tag: 67c77e68ade204f56d91ad5952fe432188b40d23 + --sha256: 0q7nwl56lgic5andc956zv4zipdv5rxjkalm21cxr75r6grkzfmy + -- -------------------------------------------------------------------------- -- -- Relaxed Bounds @@ -217,7 +235,7 @@ allow-newer: base-compat-batteries:* allow-newer: webauthn:* -- many packages use an spurious <1.5 upper bound on hashable -allow-newer: *:hashable +-- allow-newer: *:hashable allow-newer: lrucaching:base-compat diff --git a/cabal.project.freeze b/cabal.project.freeze index 2d12218e97..b22bedc30d 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1,6 +1,6 @@ active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.12.1.0, - any.Cabal-syntax ==3.12.1.0, +constraints: any.Cabal ==3.10.2.0, + any.Cabal-syntax ==3.10.2.0, any.Decimal ==0.5.2, any.Diff ==1.0.2, any.Glob ==0.10.2, @@ -91,14 +91,14 @@ constraints: any.Cabal ==3.12.1.0, any.chainweb-storage ==0.1.0.0, any.character-ps ==0.1, any.charset ==0.3.11, - any.chronos ==1.1.6.2, + any.chronos ==1.1.5.1, any.citeproc ==0.8.1.2, citeproc -executable -icu, any.clock ==0.8.4, clock -llvm, any.cmdargs ==0.10.22, cmdargs +quotation -testprog, - any.co-log-core ==0.3.2.2, + any.co-log-core ==0.3.2.3, any.code-page ==0.2.1, any.colour ==2.3.6, any.commonmark ==0.2.6.1, @@ -195,8 +195,8 @@ constraints: any.Cabal ==3.12.1.0, any.half ==0.3.2, any.happy ==2.1.3, any.happy-lib ==2.1.3, - any.hashable ==1.5.0.0, - hashable -arch-native -random-initial-seed, + any.hashable ==1.4.7.0, + hashable -arch-native +integer-gmp -random-initial-seed, any.hashes ==0.3.0.1, hashes -benchmark-cryptonite -openssl-use-pkg-config -test-cryptonite +with-openssl, any.haskeline ==0.8.2.1, @@ -331,7 +331,10 @@ constraints: any.Cabal ==3.12.1.0, reflection -slow +template-haskell, any.regex ==1.1.0.2, any.regex-base ==0.94.0.2, + any.regex-compat ==0.95.2.1, any.regex-pcre-builtin ==0.95.2.3.8.44, + any.regex-posix ==0.96.0.1, + regex-posix -_regex-posix-clib, any.regex-tdfa ==1.3.2.2, regex-tdfa +doctest -force-o2, any.resource-pool ==0.4.0.0, @@ -514,4 +517,4 @@ constraints: any.Cabal ==3.12.1.0, zip-archive -executable, any.zlib ==0.7.1.0, zlib -bundled-c-zlib +non-blocking-ffi +pkg-config -index-state: hackage.haskell.org 2024-12-14T23:51:20Z +index-state: hackage.haskell.org 2024-12-16T17:37:22Z diff --git a/chainweb.cabal b/chainweb.cabal index 33331e4932..d2d078d52e 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -363,6 +363,7 @@ library , Chainweb.Pact.Transactions.OtherTransactions , Chainweb.Pact.Transactions.RecapDevelopmentTransactions , Chainweb.Pact.Types + , Chainweb.Pact.Types.Parity , Chainweb.Pact.Utils -- utils @@ -439,6 +440,7 @@ library , pem >=0.2 , primitive >= 0.7.1.0 , random >= 1.2 + , regex-compat >= 0.95 , rocksdb-haskell-kadena >= 1.1.0 , rosetta >= 1.0 , safe-exceptions >= 0.1 @@ -637,6 +639,27 @@ test-suite chainweb-tests Chainweb.Test.Mempool.Sync Chainweb.Test.Mining Chainweb.Test.Misc + Chainweb.Test.Pact4.GrandHash + Chainweb.Test.Pact4.PactMultiChainTest + Chainweb.Test.Pact4.VerifierPluginTest + Chainweb.Test.Pact4.PactSingleChainTest + Chainweb.Test.Pact4.DbCacheTest + Chainweb.Test.Pact4.Checkpointer + Chainweb.Test.Pact4.ModuleCacheOnRestart + Chainweb.Test.Pact4.NoCoinbase + Chainweb.Test.Pact4.RewardsTest + Chainweb.Test.Pact4.PactExec + Chainweb.Test.Pact4.PactReplay + Chainweb.Test.Pact4.RemotePactTest + Chainweb.Test.Pact4.SPV + Chainweb.Test.Pact4.TransactionTests + Chainweb.Test.Pact4.TTL + Chainweb.Test.Pact4.SQLite + Chainweb.Test.Pact5.CheckpointerTest + Chainweb.Test.Pact5.PactServiceTest + Chainweb.Test.Pact5.RemotePactTest + Chainweb.Test.Pact5.SPVTest + Chainweb.Test.Pact5.TransactionExecTest Chainweb.Test.Pact4.Checkpointer Chainweb.Test.Pact4.DbCacheTest Chainweb.Test.Pact4.GrandHash @@ -706,7 +729,7 @@ test-suite chainweb-tests , exceptions , ghc-compact >= 0.1 , hashable >= 1.3 - , hashes >=0.2.2.0 + , hashes >=0.3 , hedgehog >= 1.4 , http-client >= 0.5 , http-client-tls >=0.3 @@ -745,6 +768,8 @@ test-suite chainweb-tests , tasty-hedgehog >= 1.4.0.2 , tasty-hunit >= 0.9 , tasty-json >= 0.1 + , tasty-hedgehog >= 1.4.0.2 + , tasty-hunit >= 0.9 , tasty-quickcheck >= 0.9 , text >=2.0 , time >= 1.12.2 @@ -756,9 +781,15 @@ test-suite chainweb-tests , warp >= 3.3.6 , warp-tls >= 3.4 , yaml >= 0.11 + , yet-another-logger >= 0.4.1 + if flag(ed25519) cpp-options: -DWITH_ED25519=1 +-- -------------------------------------------------------------------------- -- +-- Chainweb Node Application +-- -------------------------------------------------------------------------- -- + test-suite compaction-tests import: warning-flags, debugging-flags default-language: Haskell2010 @@ -889,6 +920,8 @@ benchmark bench , loglevel >= 0.1 , mtl >= 2.3 , pact + , pact-tng + , pact-tng:pact-request-api , random >= 1.2 , streaming , text >= 2.0 diff --git a/classify-diffs b/classify-diffs new file mode 100755 index 0000000000..625d116ba7 --- /dev/null +++ b/classify-diffs @@ -0,0 +1,227 @@ +#!/usr/bin/env sh + +mkdir -p diffs/loaded-module-hash/ +mkdir -p diffs/failed-deserialize-module +mkdir -p diffs/keyset-failure +mkdir -p diffs/too-many-arguments +mkdir -p diffs/gas-exceeded +mkdir -p diffs/unbound-free-variable +mkdir -p diffs/expected-bool-got-unit +mkdir -p diffs/no-such-key-in-table +mkdir -p diffs/keyset-defined +mkdir -p diffs/wiza-equipped-item +mkdir -p diffs/read-keyset-error +mkdir -p diffs/nft-mint-mystery +mkdir -p diffs/cannot-find-module +mkdir -p diffs/table-not-found +mkdir -p diffs/interface-loaded +mkdir -p diffs/minimum-precision +mkdir -p diffs/module-admin +mkdir -p diffs/no-such-member +mkdir -p diffs/capability-already-installed +mkdir -p diffs/token-protocol-violation +mkdir -p diffs/failed-to-call-at +mkdir -p diffs/output-differs-int-double +mkdir -p diffs/no-pact-exec-in-cr +mkdir -p diffs/table-already-exists +mkdir -p diffs/non-pact-value +mkdir -p diffs/quiz-results +mkdir -p diffs/read-function-failures +mkdir -p diffs/read-function-failures +mkdir -p diffs/lago-finance +mkdir -p diffs/db-internal-error +mkdir -p diffs/invalid-call-to-if +mkdir -p diffs/incompatible-types +mkdir -p diffs/b64-diffs +mkdir -p diffs/interface-as-mod-ref +mkdir -p diffs/marmalade-v2 +mkdir -p diffs/kadena-mining-club +mkdir -p diffs/kadena-mining-club +mkdir -p diffs/kadena-mining-club-format +mkdir -p diffs/interface-impl-errors +mkdir -p diffs/minimum-precision +mkdir -p diffs/dao-hive-factory +mkdir -p diffs/invalid-def-in-term-var +mkdir -p diffs/desugar-syntax-failure +mkdir -p diffs/duplicate-table-error +mkdir -p diffs/cap-is-not-managed +mkdir -p diffs/kedao +mkdir -p diffs/list-commas +mkdir -p diffs/transfer-exceeded +mkdir -p diffs/sort-object-divergence +mkdir -p diffs/interesting + +classify_diff() { + grep -q 'Loaded module' "$1" && mv -f "$1" diffs/loaded-module-hash/ && return + grep -q 'Failed to deserialize but found value at' "$1" && mv -f "$1" diffs/failed-deserialize-module && return + grep -q 'Keyset failure' "$1" && mv -f "$1" diffs/keyset-failure && return + grep -q 'Attempted to apply a closure to too many arguments' "$1" && mv -f "$1" diffs/too-many-arguments && return + grep -q 'Failure parsing decimal: Object' "$1" && mv -f "$1" diffs/parse-decimal-object && return + grep -q 'GasError' "$1" && mv -f "$1" diffs/gas-exceeded && return + grep -q 'Unbound free variable' "$1" && mv -f "$1" diffs/unbound-free-variable && return + grep -q 'expected bool value, got \(\)' "$1" && mv -f "$1" diffs/expected-bool-got-unit && return + grep -q 'invariant violated: No such key .* in table' "$1" && mv -f "$1" diffs/no-such-key-in-table && return + grep -q 'Keyset write success' "$1" && mv -f "$1" diffs/keyset-defined && return + grep -q 'equipped' "$1" && mv -f "$1" diffs/wiza-equipped-item && return + grep -q 'read-keyset failure' "$1" && mv -f "$1" diffs/read-keyset-error && return + grep -q 'New reward balance for' "$1" && mv -f "$1" diffs/nft-mint-mystery && return + grep -q 'Cannot resolve' "$1" && mv -f "$1" diffs/cannot-find-module && return + grep -q 'Cannot find module:' "$1" && mv -f "$1" diffs/cannot-find-module && return + grep -q 'Table .* not found' "$1" && mv -f "$1" diffs/table-not-found && return + grep -q 'Loaded interface' "$1" && mv -f "$1" diffs/interface-loaded && return + grep -q 'Amount violates minimum precision' "$1" && mv -f "$1" diffs/minimum-precision && return + grep -q 'Module admin necessary' "$1" && mv -f "$1" diffs/module-admin && return + grep -q 'has no such member' "$1" && mv -f "$1" diffs/no-such-member && return + grep -q 'Capability already installed' "$1" && mv -f "$1" diffs/capability-already-installed && return + grep -q 'Token protocol violation' "$1" && mv -f "$1" diffs/token-protocol-violation && return + grep -q 'capability is not managed and cannot be installed' "$1" && mv -f "$1" diffs/cap-is-not-managed && return + grep -q 'failed to call native function at with argument(s) of type(s)' "$1" && mv -f "$1" diffs/failed-to-call-at && return + grep -q '{"status":"success","data":{"int"' "$1" && mv -f "$1" diffs/output-differs-int-double && return + grep -q 'Continuation Error: verifyCont' "$1" && mv -f "$1" diffs/no-pact-exec-in-cr && return + grep -q 'Table .* already exists' "$1" && mv -f "$1" diffs/table-already-exists && return + grep -q 'Expected Pact Value, got closure or table reference' "$1" && mv -f "$1" diffs/non-pact-value && return + grep -q '"source":"quiz_' "$1" && mv -f "$1" diffs/quiz-results && return + grep -q 'read-decimal failure' "$1" && mv -f "$1" diffs/read-function-failures && return + grep -q 'No such key in message' "$1" && mv -f "$1" diffs/read-function-failures && return + grep -q 'Runtime typecheck failure, argument is table , but expected type object' "$1" && mv -f "$1" diffs/lago-finance && return + grep -q 'user error (Database error: ErrorError)' "$1" && mv -f "$1" diffs/db-internal-error && return + grep -q 'Invalid arguments in call to if' "$1" && mv -f "$1" diffs/invalid-call-to-if && return + grep -q 'cannot compare incompatible types' "$1" && mv -f "$1" diffs/incompatible-types && return + grep -q 'invalid b64' "$1" && mv -f "$1" diffs/b64-diffs && return + grep -q 'Invalid Interface attempted to be used as module reference' "$1" && mv -f "$1" diffs/interface-as-mod-ref && return + grep -q 'Expected module, found interface' "$1" && mv -f "$1" diffs/interface-as-mod-ref && return + grep -q '"module":{"namespace":"marmalade-v2","name":"ledger"}' "$1" && mv -f "$1" diffs/marmalade-v2 && return + grep -q 'Succesfully claimed' "$1" && grep -q 'CLAIM' "$1" && mv -f "$1" diffs/kadena-mining-club && return + grep -q '{"status":"success","data":"Price updated to' "$1" && mv -f "$1" diffs/kadena-mining-club && return + grep -q 'Invalid arguments in call to format' "$1" && mv -f "$1" diffs/kadena-mining-club-format && return + grep -q 'does not correctly implement the function' "$1" && mv -f "$1" diffs/interface-impl-errors && return + grep -q 'Amount violates minimum denomination' "$1" && mv -f "$1" diffs/minimum-precision && return + grep -q 'dao-hive-factory' "$1" && mv -f "$1" diffs/dao-hive-factory && return + grep -q 'Invalid definition in term variable position' "$1" && mv -f "$1" diffs/invalid-def-in-term-var && return + grep -q 'Desugar syntax failure' "$1" && mv -f "$1" diffs/desugar-syntax-failure && return + grep -q 'PactDuplicateTableError' "$1" && mv -f "$1" diffs/duplicate-table-error && return + grep -q 'redeem-for-kda' "$1" && mv -f "$1" diffs/kedao && return +} + +for f in parity-replay-diffs/*; do + classify_diff "$f" & +done; +wait; + +mv -f parity-replay-diffs/DWbywTHYKnP4M_G4xcOkKy3wuSKIE2INlkJVTX67cZA.md diffs/sort-object-divergence 2> /dev/null + +mv -f parity-replay-diffs/C8E7Bjh1NQS11IsYjPt6Rv6__2IvIS8rM0oUSB5_fC8.md diffs/transfer-exceeded 2>/dev/null +mv -f parity-replay-diffs/AyzyMGgYJU15zWbSui1H9Sfoilt7dtoq_veaN9Zou9E.md diffs/transfer-exceeded 2>/dev/null +mv -f parity-replay-diffs/JDvsKyn5mkVbhFL3vB3CYgMhXjP-GxtgmDkQjGBo7nE.md diffs/transfer-exceeded 2>/dev/null +mv -f parity-replay-diffs/Xu0pBwJr2iDN1tMvXDcgKBm9jHfiteHUoYWmTxXvofA.md diffs/transfer-exceeded 2>/dev/null +mv -f parity-replay-diffs/Yf7Ci5v_HYSi7ZXM5lU2HJDE95KfmwrfYMJBpw423-M.md diffs/transfer-exceeded 2>/dev/null +mv -f parity-replay-diffs/akGcLF72Xjo2S1WeUWnzAY7nkGri-Qm6eE81EF0spTs.md diffs/transfer-exceeded 2>/dev/null +mv -f parity-replay-diffs/nvF7okrNzUFWLIaEt5BFLFPUmXnMEQGAGzBSef05pXQ.md diffs/transfer-exceeded 2>/dev/null +mv -f parity-replay-diffs/qr3EGV8i5-5aNL0m453R8v5U5xFsHJmZBcWTyNde7G8.md diffs/transfer-exceeded 2>/dev/null +# mv -f parity-replay-diffs/_HFqdbIlHNdS8wNgMdNGlkkuhjD4ZllxNL7fTg6EhO0.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/TFcV7ZlgIUavNezrrMjv_40-s3rYwxXdN9hAuSX52yo.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/XKGDNtQNgeGTUQwclhSu5Bzat3XNzClDh_teQ_ET4zE.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/IERmriVgG_Y5FLBMSAb0s70wuq8vFmRheSxALFPArrg.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/1q7J661naTNdALjAow6N0FdNwWUD2qDKI7H2ah594xw.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/KBZEw8l7d3pSwVmEDgPZ8lsNT9xZL1KOI3zYJymLfj8.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/iZTMwypb6iyq85e9lryzMstcoHkM-B6ihG95AhPRk_M.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/2WUTwvO39Z0izsAP1xZsa7cQHtVlxHR2S4ldBdsWUMA.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/pqpNMUvjBmflJEwRbka4pugkfOw3_bloewnfGZ6i4LE.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/jiZrj-NUMGEp1XcVni3gufkjtYItszFd1zjV66hRwhE.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/Akt5RUolyR4bzS2u0xpDrMoR5PdLAHKHp1h4HpBcVVo.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/0wpwNj7bvh4y9Ax_zmjHzRiKa96pc2Co1ZeDFNK7oac.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/uZrgs9xLthCx-bc53_drXnRSkra4pf9ddw65fC_ZGm4.md diffs/interesting 2> /dev/null +# mv -f parity-replay-diffs/-WQoBV7Ah6VVYtvkkiQ8eIcXeQx_MymbtWW6NxpmPBU.md diffs/interesting 2> /dev/null + +# # Format list commas +mv -f parity-replay-diffs/ijcy5AXfsShzvXbGK9olHUNH3TETD6D-i9CV172nlg8.md diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/eXq55WivCpojMa20KjK35uCurSHZVvkZmDggkX4fOuI.md diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/VqL6Z6IBs7KOyHAiVNgnrdbysO5KYsJ2A2-HWGYc2eo.md diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/uR88qo2v4EPLGxqUfuslJOeeD_QUVKzZE5mY6XauAr8.md diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/rjW-iQb8iQa0vwIRBR8dUwEDANpxAncJS1jFh03CoOo.md diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/1yQj* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/2Ezlo* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/55Rb* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/8AlDhPu* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/9Fay* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/AOX-* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/B5Rzza* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/BZXIVH1* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/C74x1Z* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/CuKgdq* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/EvT4O5* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/FaKS9oeM1* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/HkmM-E-E* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/HokKpbB* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/J0sx5Dn4* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/KZfw7k_* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/LlqEI6cmj* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/M5XlcCulO* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/N1B00xukn* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/NXNM-nOG* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/NcX0YuW* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/PVsWnj56UI* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/QYKr5vuJg* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/RPm_ubGz4E4* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/RRNp6BE* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/RusfQbF01* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/WT0szcz-* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/Yqd8T_K* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/bZRp5YSby* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/bs5FTZvQN* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/cVfSGQzc* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/e1QB68* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/gs5aH_* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/k7OMew9* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/kt1pXg* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/lvbSGLTH* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/m_Pdn2-TR* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/maBViIK* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/n7poPsh* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/nBK4DVXYK* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/ptBRIkxnEt7BaI* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/qFM5xe47xky* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/rHXwEDb* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/rZu4C3pH0q7* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/rf_2uVai* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/rjW-iQb8i* diffs/list-commas 2> /dev/null +mv -f parity-replay-diffs/s6w1VVITn* diffs/list-commas 2> /dev/null + +mv -f parity-replay-diffs/EMaD-w9ConQkyLfg6_RsfNtld-fS1pEclfTSwtRdNzs.md diffs/interesting 2> /dev/null + +# mv parity-replay-diffs/14RYfa6_zc8UTWPNyMOqV00jfApmk6spD3v9z7OvwWA.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/AtlJbN56F2H_ibfuOfepu3NNiVMy8i9SJp6NIUZUkqM.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/D1cMZW_len_iahiowulPTebPAK0Quk-v20R_3H788iE.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/F4rREqcjnX4Rztsxu4zKX6r_lMRCSAtiZcsjAehTdCE.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/J4KyKYgAiW8_OTZEZd8CmAMzdWUk6EYSg9GKHUkPImA.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/JhytcMWLjNGQpDXUtggon3mtwoxvsycr7vfnV-DFHtQ.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/OdPvy5wglBEBlzShcVqteVeOhl1y9_wKP9JhNoaxEe0.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/QOCbuI9-WMG-GoiI7vkgRibFO6PEDu4A2SeVMpAuACw.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/U5WaTSf9UZ1TCJr3bAxa9iy-205aGjzAH-ESi42Om4k.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/Whq99lwfCvAYWI9ey8fVND3p8jVrTGfBwsu9IXEYGyc.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/XPNOBrNUUZChmn8CVOV-CKg0xJse0uu25MVpmT-mfH0.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/Xx8Kt_4YePIND13ZVq8F9grrxzNLCyV-KisBmtO8HMw.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/ZlCeumS6KmXBRp9M5B-Hd0w2r49iaj874jbHT-ELDDg.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/gRqhSl-5-U_l77W-5cgryrFU_L5hwY6XJTgNLSU3tTI.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/ijiMoA3JgIDgdol5va92QBtfpw1rFGJjN5Lz36hgBzs.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/lLoPxT_J0gbB1GzGkcjmAWt1fph8kMfJrsRoHZQf8Sw.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/lewljJ2a40a9nMHTncarl3Se3ZBgHYkxV9TJbgfEGks.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/mSKGH1KhSQIY_FpWWXrUimKh1QQALYGfnv4f1Nn28Hk.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/mXl9L4xl8pzrK8tOf2PVEKF-AmtofRnOZmvy4MX4Rc8.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/oXynyHlhJgoT2YEl-JSSUbWO95DGOU6aO08QrYVpvNU.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/uHM_66xiDIxpB9CQzxKoNbtYfJ6hkfl1PU_2PvAyl4E.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/uQrg01VcUBUoNeZgQ22MukbUrAN4l9AIzUiCOlhVp6I.md diffs/interesting 2> /dev/null +# mv parity-replay-diffs/wKWF6E3-kuuhAn7o9vPY9amI8oN5RjROaZlwVHPp4B0.md diffs/interesting 2> /dev/null + + # diffCount=$(find parity-replay-diffs -type f -exec echo -n "." \; | wc -c) + # file_count=$(find parity-replay-diffs -type f -exec echo -n "." \; | wc -c) + + # echo "Remaining diffs: $diffCount" + # Check if there are any files remaining + # if [ "$file_count" -gt 0 ]; then + # echo "Number of files: $file_count" + # echo "Remaining files:" + # find parity-replay-diffs -type f + # else + # echo "No files remaining." + # fi diff --git a/node/src/ChainwebNode.hs b/node/src/ChainwebNode.hs index 6ded0f6f06..4682b9cc1e 100644 --- a/node/src/ChainwebNode.hs +++ b/node/src/ChainwebNode.hs @@ -56,6 +56,7 @@ import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Managed +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time @@ -334,7 +335,7 @@ node conf logger = do pactDbDir <- getPactDbDir conf dbBackupsDir <- getBackupsDir conf withRocksDb' <- - if _configOnlySyncPact cwConf || _configReadOnlyReplay cwConf + if _configOnlySyncPact cwConf || isJust (_configReplay cwConf) then if _cutPruneChainDatabase (_configCuts cwConf) == GcNone then withReadOnlyRocksDb <$ logFunctionText logger Info "Opening RocksDB in read-only mode" @@ -345,7 +346,8 @@ node conf logger = do logFunctionText logger Info $ "opened rocksdb in directory " <> sshow rocksDbDir logFunctionText logger Debug $ "backup config: " <> sshow (_configBackup cwConf) withChainweb cwConf logger rocksDb pactDbDir dbBackupsDir (_nodeConfigResetChainDbs conf) $ \case - Replayed _ _ -> return () + Rewound {} -> return () + ReadOnlyReplayed {} -> return () StartedChainweb cw -> do let telemetryEnabled = _enableConfigEnabled $ _logConfigTelemetryBackend $ _nodeConfigLog conf @@ -383,7 +385,7 @@ withNodeLogger logCfg chainwebCfg v f = runManaged $ do -- we don't log tx failures in replay let !txFailureHandler = - if _configOnlySyncPact chainwebCfg || _configReadOnlyReplay chainwebCfg + if _configOnlySyncPact chainwebCfg || isJust (_configReplay chainwebCfg) then [dropLogHandler (Proxy :: Proxy Pact4TxFailureLog), dropLogHandler (Proxy :: Proxy Pact5TxFailureLog)] else [] diff --git a/rerun-diff b/rerun-diff new file mode 100755 index 0000000000..edcde743fb --- /dev/null +++ b/rerun-diff @@ -0,0 +1,29 @@ +#!/usr/bin/env sh + +# required for jq to affect exit codes +set -o pipefail + +if [ $# -ne 1 ] + then + echo "Needs one argument" +fi + +[ -z "${CHAINWEB_DB_DIR}" ] && + echo "CHAINWEB_DB_DIR must be set to the mainnet db directory" && exit 1 + +# $1 - the diff to re-run +DIFF_FILENAME=$(basename "$1") +REQUEST_KEY=${DIFF_FILENAME%.*} + +set -x + +cabal run chainweb-node -- \ + --replay \"$REQUEST_KEY\" \ + --database-directory=$CHAINWEB_DB_DIR \ + --log-level=error \ + --enable-ignore-bootstrap-nodes \ + --bootstrap-reachability=0 \ + --enable-private \ + --p2p-port=0 \ + --service-port=0 +# choose ports at random diff --git a/rerun-diffs.sh b/rerun-diffs.sh new file mode 100755 index 0000000000..060f7ae177 --- /dev/null +++ b/rerun-diffs.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env sh + +# this script will take all of the diffs in `./old-diffs/`, and re-run them into `./diffs/` + +[ -z "${CHAINWEB_DB_DIR}" ] && + echo "CHAINWEB_DB_DIR must be set to the mainnet db directory" && exit 1 + +# do not even re-run discreps in these classes. +# maybe they're too large, maybe they're intentional semantic divergences +unchecked_classes=$(cat unchecked-diff-classes) +# this builds a find-invocation that ignores those classes +prune_stmt=$(for cls in $unchecked_classes; do echo -n "-not ( -path old-diffs/$cls -prune ) "; done) + +cabal build chainweb-node + +# we can't use parallelism here because of a mysterious SQLITE_BUSY when we do +# the unquoted $prune_stmt is intentional +echo "Rerunning #diffs $(find old-diffs/ $prune_stmt -type f | wc -l)" +find old-diffs/ $prune_stmt -type f -print0 | parallel -j1 -0 ./rerun-diff {} +./classify-diffs +for f in $unchecked_classes; do + rm -rf "diffs/$f" +done +rm -rf /tmp/rerun-diff* diff --git a/src/Chainweb/Chainweb.hs b/src/Chainweb/Chainweb.hs index 0dc8cdc7ef..2f1dc470bf 100644 --- a/src/Chainweb/Chainweb.hs +++ b/src/Chainweb/Chainweb.hs @@ -160,7 +160,7 @@ import Chainweb.Miner.Config import qualified Chainweb.OpenAPIValidation as OpenAPIValidation import Chainweb.Pact.Backend.Types(IntraBlockPersistence(..)) import Chainweb.Pact.RestAPI.Server (PactServerData(..)) -import Chainweb.Pact.Types (PactServiceConfig(..)) +import Chainweb.Pact.Types (PactServiceConfig(..), ReplayTarget (..)) import Chainweb.Pact4.Validations import Chainweb.Payload.PayloadStore import Chainweb.Payload.PayloadStore.RocksDB @@ -334,7 +334,8 @@ validatingMempoolConfig cid v gl gp mv = Mempool.InMemConfig data StartedChainweb logger where StartedChainweb :: (CanReadablePayloadCas cas, Logger logger) => !(Chainweb logger cas) -> StartedChainweb logger - Replayed :: !Cut -> !(Maybe Cut) -> StartedChainweb logger + ReadOnlyReplayed :: ![(ChainId, ReplayTarget BlockHeader)] -> StartedChainweb logger + Rewound :: Cut -> Maybe Cut -> StartedChainweb logger data ChainwebStatus = ProcessStarted @@ -366,7 +367,7 @@ withChainwebInternal -> IO () withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir resetDb inner = do - unless (_configOnlySyncPact conf || _configReadOnlyReplay conf) $ + unless (_configOnlySyncPact conf || isJust (_configReplay conf)) $ initializePayloadDb v payloadDb -- Garbage Collection @@ -507,41 +508,46 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re let pactSyncChains = case _configSyncPactChains conf of - Just syncChains | _configOnlySyncPact conf || _configReadOnlyReplay conf -> HM.filterWithKey (\k _ -> elem k syncChains) cs - _ -> cs + Just syncChains + | _configOnlySyncPact conf || isJust (_configReplay conf) + -> HM.filterWithKey (\k _ -> elem k syncChains) cs + _ -> cs - if _configReadOnlyReplay conf + if isJust (_configReplay conf) then do logFunctionJson logger Info PactReplayInProgress -- note that we don't use the "initial cut" from cutdb because its height depends on initialBlockHeightLimit. - highestCut <- - unsafeMkCut v <$> readHighestCutHeaders v (logFunctionText logger) webchain (cutHashesTable rocksDb) - lowerBoundCut <- - tryLimitCut webchain (fromMaybe 0 $ _cutInitialBlockHeightLimit $ _configCuts conf) highestCut - upperBoundCut <- forM (_cutFastForwardBlockHeightLimit $ _configCuts conf) $ \upperBound -> - tryLimitCut webchain upperBound highestCut + targets :: [(ChainId, ChainResources logger, ReplayTarget BlockHeader)] <- case _configReplay conf of + Nothing -> error "impossible" + Just (ReplayTargetBlockRange l u) -> do + highestCut <- + unsafeMkCut v <$> readHighestCutHeaders v (logFunctionText logger) webchain (cutHashesTable rocksDb) + lowerBoundCut <- + tryLimitCut webchain l highestCut + maybeUpperBoundCut <- forM u $ \upperBound -> + tryLimitCut webchain upperBound highestCut + return $ + [ (cid, res, ReplayTargetBlockRange (_cutMap lowerBoundCut HM.! cid) (maybeUpperBoundCut <&> (^?! (cutMap . ix cid)))) + | (cid, res) <- HM.toList pactSyncChains + ] + Just (ReplayTargetTx t) -> return + [ (cid, res, ReplayTargetTx t) + | (cid, res) <- HM.toList pactSyncChains + ] let - replayOneChain :: (ChainResources logger, (BlockHeader, Maybe BlockHeader)) -> IO () - replayOneChain (cr, (l, u)) = do + replayOneChain :: (ChainId, ChainResources logger, ReplayTarget BlockHeader) -> IO () + replayOneChain (cid, cr, target) = do let chainPact = _chainResPact cr let logCr = logFunctionText $ addLabel ("component", "pact") $ addLabel ("sub-component", "init") $ _chainResLogger cr - void $ _pactReadOnlyReplay chainPact l u + void $ _pactReplay chainPact cid target logCr Info "pact db synchronized" - let bounds = - HM.intersectionWith (,) - pactSyncChains - (HM.mapWithKey - (\cid bh -> - (bh, (HM.! cid) . _cutMap <$> upperBoundCut)) - (_cutMap lowerBoundCut) - ) - mapConcurrently_ replayOneChain bounds + mapConcurrently_ replayOneChain targets logg Info "finished fast forward replay" logFunctionJson logger Info PactReplaySuccessful - inner $ Replayed lowerBoundCut upperBoundCut + inner $ ReadOnlyReplayed [ (cid, target) | (cid, _, target) <- targets ] else if _configOnlySyncPact conf then do initialCut <- _cut mCutDb @@ -556,7 +562,7 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re synchronizePactDb pactSyncChains newCut logg Info "finished replaying Pact DBs to fast forward cut" logFunctionJson logger Info PactReplaySuccessful - inner $ Replayed initialCut (Just newCut) + inner $ Rewound initialCut (Just newCut) else do initialCut <- _cut mCutDb logg Info "start synchronizing Pact DBs to initial cut" @@ -627,7 +633,7 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re , _cutDbParamsTelemetryLevel = Info , _cutDbParamsInitialHeightLimit = _cutInitialBlockHeightLimit cutConf , _cutDbParamsFastForwardHeightLimit = _cutFastForwardBlockHeightLimit cutConf - , _cutDbParamsReadOnly = _configOnlySyncPact conf || _configReadOnlyReplay conf + , _cutDbParamsReadOnly = _configOnlySyncPact conf || isJust (_configReplay conf) } where cutConf = _configCuts conf diff --git a/src/Chainweb/Chainweb/Configuration.hs b/src/Chainweb/Chainweb/Configuration.hs index 90b2009f15..50b2d5a092 100644 --- a/src/Chainweb/Chainweb/Configuration.hs +++ b/src/Chainweb/Chainweb/Configuration.hs @@ -113,7 +113,7 @@ import Chainweb.HostAddress import qualified Chainweb.Mempool.Mempool as Mempool import Chainweb.Mempool.P2pConfig import Chainweb.Miner.Config -import Chainweb.Pact.Types (defaultReorgLimit, defaultModuleCacheLimit, defaultPreInsertCheckTimeout) +import Chainweb.Pact.Types (defaultReorgLimit, defaultModuleCacheLimit, defaultPreInsertCheckTimeout, ReplayTarget) import Chainweb.Pact.Types (RewindLimit(..)) import Chainweb.Payload.RestAPI (PayloadBatchLimit(..), defaultServicePayloadBatchLimit) import Chainweb.Utils @@ -403,7 +403,7 @@ data ChainwebConfiguration = ChainwebConfiguration , _configRosettaConstructionApi :: !Bool , _configBackup :: !BackupConfig , _configServiceApi :: !ServiceApiConfig - , _configReadOnlyReplay :: !Bool + , _configReplay :: !(Maybe (ReplayTarget BlockHeight)) -- ^ do a read-only replay using the cut db params for the block heights , _configOnlySyncPact :: !Bool -- ^ exit after synchronizing pact dbs to the latest cut @@ -467,12 +467,12 @@ validateChainwebVersion v = do , sshow (_versionName v) ] -- FIXME Pact5: disable - when (v == mainnet || v == testnet04) $ - throwError $ T.unwords - [ "This node version is a technical preview of Pact 5, and" - , "cannot be used with Pact 4 chainweb versions (testnet04, mainnet)" - , "just yet." - ] + -- when (v == mainnet || v == testnet04) $ + -- throwError $ T.unwords + -- [ "This node version is a technical preview of Pact 5, and" + -- , "cannot be used with Pact 4 chainweb versions (testnet04, mainnet)" + -- , "just yet." + -- ] where isDevelopment = _versionCode v `elem` [_versionCode dv | dv <- [recapDevnet, devnet, pact5Devnet]] @@ -506,7 +506,7 @@ defaultChainwebConfiguration v = ChainwebConfiguration , _configFullHistoricPactState = True , _configServiceApi = defaultServiceApiConfig , _configOnlySyncPact = False - , _configReadOnlyReplay = False + , _configReplay = Nothing , _configSyncPactChains = Nothing , _configBackup = defaultBackupConfig , _configModuleCacheLimit = defaultModuleCacheLimit @@ -535,7 +535,7 @@ instance ToJSON ChainwebConfiguration where , "fullHistoricPactState" .= _configFullHistoricPactState o , "serviceApi" .= _configServiceApi o , "onlySyncPact" .= _configOnlySyncPact o - , "readOnlyReplay" .= _configReadOnlyReplay o + , "replay" .= _configReplay o , "syncPactChains" .= _configSyncPactChains o , "backup" .= _configBackup o , "moduleCacheLimit" .= _configModuleCacheLimit o @@ -568,7 +568,7 @@ instance FromJSON (ChainwebConfiguration -> ChainwebConfiguration) where <*< configFullHistoricPactState ..: "fullHistoricPactState" % o <*< configServiceApi %.: "serviceApi" % o <*< configOnlySyncPact ..: "onlySyncPact" % o - <*< configReadOnlyReplay ..: "readOnlyReplay" % o + <*< configReplay ..: "replay" % o <*< configSyncPactChains ..: "syncPactChains" % o <*< configBackup %.: "backup" % o <*< configModuleCacheLimit ..: "moduleCacheLimit" % o @@ -624,8 +624,8 @@ pChainwebConfiguration = id <*< configOnlySyncPact .:: boolOption_ % long "only-sync-pact" <> help "Terminate after synchronizing the pact databases to the latest cut" - <*< configReadOnlyReplay .:: boolOption_ - % long "read-only-replay" + <*< configReplay .:: fmap Just % jsonOption + % long "replay" <> help "Replay the block history non-destructively" <*< configSyncPactChains .:: fmap Just % jsonOption % long "sync-pact-chains" diff --git a/src/Chainweb/Pact/Backend/Utils.hs b/src/Chainweb/Pact/Backend/Utils.hs index 30a078e90c..6861d17557 100644 --- a/src/Chainweb/Pact/Backend/Utils.hs +++ b/src/Chainweb/Pact/Backend/Utils.hs @@ -333,7 +333,7 @@ withInMemSQLiteConnection = withSQLiteConnection ":memory:" open2 :: String -> IO (Either (SQ3.Error, SQ3.Utf8) SQ3.Database) open2 file = open_v2 (fromString file) - (collapseFlags [sqlite_open_readwrite , sqlite_open_create , sqlite_open_fullmutex]) + (collapseFlags [sqlite_open_readwrite , sqlite_open_nomutex]) Nothing -- Nothing corresponds to the nullPtr collapseFlags :: [SQLiteFlag] -> SQLiteFlag @@ -341,10 +341,12 @@ collapseFlags xs = if Prelude.null xs then error "collapseFlags: You must pass a non-empty list" else Prelude.foldr1 (.|.) xs -sqlite_open_readwrite, sqlite_open_create, sqlite_open_fullmutex :: SQLiteFlag +sqlite_open_readonly, sqlite_open_readwrite, sqlite_open_create, sqlite_open_fullmutex, sqlite_open_nomutex :: SQLiteFlag +sqlite_open_readonly = 0x00000001 sqlite_open_readwrite = 0x00000002 sqlite_open_create = 0x00000004 sqlite_open_fullmutex = 0x00010000 +sqlite_open_nomutex = 0x00008000 commitBlockStateToDatabase :: SQLiteEnv -> BlockHash -> BlockHeight -> BlockHandle -> IO () commitBlockStateToDatabase db hsh bh blockHandle = do diff --git a/src/Chainweb/Pact/Conversion.hs b/src/Chainweb/Pact/Conversion.hs index 4003bdf572..08a4908781 100644 --- a/src/Chainweb/Pact/Conversion.hs +++ b/src/Chainweb/Pact/Conversion.hs @@ -3,7 +3,8 @@ module Chainweb.Pact.Conversion ( fromLegacyQualifiedName - , fromLegacyPactValue) + , fromLegacyPactValue + ) where import qualified Pact.Types.Term as Legacy @@ -94,3 +95,101 @@ fromLegacyModuleName -> ModuleName fromLegacyModuleName (Legacy.ModuleName n ns) = ModuleName n (fromLegacyNamespaceName <$> ns) + +{-# LANGUAGE ScopedTypeVariables, LambdaCase, BangPatterns, TupleSections, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- module Chainweb.Pact.Conversion +-- ( fromLegacyQualifiedName +-- , fromLegacyPactValue +-- ) +-- where + +-- import qualified Pact.Types.Term as Legacy +-- import qualified Pact.Types.Exp as Legacy +-- import qualified Pact.Types.PactValue as Legacy +-- import qualified Data.Set as S +-- import qualified Data.Map.Strict as M + +-- import Pact.Core.ModRefs +-- import Pact.Core.Literal +-- import Pact.Core.Names +-- import Pact.Core.Guards +-- import Pact.Core.PactValue + + +-- fromLegacyQualifiedName +-- :: Legacy.QualifiedName +-- -> QualifiedName +-- fromLegacyQualifiedName (Legacy.QualifiedName mn n _) = +-- QualifiedName n (fromLegacyModuleName mn) + +-- fromLegacyLiteral +-- :: Legacy.Literal +-- -> Either Literal PactValue +-- fromLegacyLiteral = \case +-- Legacy.LString s -> Left (LString s) +-- Legacy.LInteger i -> Left (LInteger i) +-- Legacy.LDecimal d -> Left (LDecimal d) +-- Legacy.LBool b -> Left (LBool b) +-- Legacy.LTime l -> Right $ PTime l + +-- fromLegacyPactId +-- :: Legacy.PactId +-- -> DefPactId +-- fromLegacyPactId (Legacy.PactId pid) = DefPactId pid + +-- fromLegacyPactValue :: Legacy.PactValue -> Either String PactValue +-- fromLegacyPactValue = \case +-- Legacy.PLiteral l -> pure $ either PLiteral id $ fromLegacyLiteral l +-- Legacy.PList p -> do +-- l <- traverse fromLegacyPactValue p +-- pure (PList l) +-- Legacy.PObject (Legacy.ObjectMap om) -> do +-- om' <- traverse fromLegacyPactValue om +-- pure (PObject $ M.mapKeys (\(Legacy.FieldKey k) -> Field k) om') +-- Legacy.PGuard g -> case g of +-- Legacy.GPact (Legacy.PactGuard p n) -> let +-- p' = fromLegacyPactId p +-- in pure (PGuard (GDefPactGuard (DefPactGuard p' n))) +-- Legacy.GKeySet (Legacy.KeySet k pred') -> let +-- ks = S.map (PublicKeyText . Legacy._pubKey) k +-- p' = \case +-- (Legacy.Name (Legacy.BareName bn _def)) +-- | bn == "keys-all" -> pure KeysAll +-- | bn == "keys-any" -> pure KeysAny +-- | bn == "keys-2" -> pure Keys2 +-- (Legacy.Name (Legacy.BareName bn _def)) -> pure (CustomPredicate (TBN $ BareName bn)) +-- (Legacy.QName qn) -> pure (CustomPredicate (TQN $ fromLegacyQualifiedName qn)) +-- o -> Left $ "fromLegacyPactValue: pred invariant: " <> show o +-- in (PGuard . GKeyset . KeySet ks <$> p' pred') +-- Legacy.GKeySetRef (Legacy.KeySetName ksn ns) -> let +-- ns' = fromLegacyNamespaceName <$> ns +-- in pure (PGuard . GKeySetRef $ KeySetName ksn ns') +-- Legacy.GModule (Legacy.ModuleGuard mn n) -> let +-- mn' = fromLegacyModuleName mn +-- in pure (PGuard $ GModuleGuard (ModuleGuard mn' n)) +-- Legacy.GUser (Legacy.UserGuard n a) -> case n of +-- Legacy.QName n' -> do +-- let qn = fromLegacyQualifiedName n' +-- args <- traverse fromLegacyPactValue a +-- pure (PGuard $ GUserGuard (UserGuard qn args)) +-- _ -> Left "fromLegacyPactValue: invariant" +-- Legacy.GCapability (Legacy.CapabilityGuard n a i) -> do +-- let qn = fromLegacyQualifiedName n +-- args <- traverse fromLegacyPactValue a +-- pure (PGuard $ GCapabilityGuard (CapabilityGuard qn args (fromLegacyPactId <$> i))) +-- Legacy.PModRef (Legacy.ModRef mn mmn _) -> let +-- mn' = fromLegacyModuleName mn +-- imp = S.fromList $ maybe [] (map fromLegacyModuleName) mmn +-- in pure (PModRef $ ModRef mn' imp) + + +-- fromLegacyNamespaceName :: Legacy.NamespaceName -> NamespaceName +-- fromLegacyNamespaceName (Legacy.NamespaceName ns) = NamespaceName ns + +-- fromLegacyModuleName +-- :: Legacy.ModuleName +-- -> ModuleName +-- fromLegacyModuleName (Legacy.ModuleName n ns) +-- = ModuleName n (fromLegacyNamespaceName <$> ns) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index f32b117b5f..6e35b41d30 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -35,7 +35,7 @@ module Chainweb.Pact.PactService , execPreInsertCheckReq , execBlockTxHistory , execHistoricalLookup - , execReadOnlyReplay + , execReplay , execSyncToBlock , runPactService , withPactService @@ -113,6 +113,8 @@ import Chainweb.TreeDB import Chainweb.Utils hiding (check) import Chainweb.Version import Chainweb.Version.Guards +import Chainweb.Version.Mainnet +import Chainweb.Version.Testnet04 import Utils.Logging.Trace import Chainweb.Counter import Data.Time.Clock @@ -120,19 +122,28 @@ import Text.Printf import Data.Time.Format.ISO8601 import qualified Chainweb.Pact.PactService.Pact4.ExecBlock as Pact4 import qualified Chainweb.Pact4.Types as Pact4 -import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5 -import qualified Pact.Core.Command.Types as Pact5 -import qualified Pact.Core.Hash as Pact5 import qualified Data.ByteString.Short as SB import Data.Coerce (coerce) import Data.Void -import qualified Chainweb.Pact5.Types as Pact5 -import qualified Chainweb.Pact.PactService.Pact5.ExecBlock as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import qualified Pact.Core.Names as Pact5 import Data.Functor.Product -import qualified Chainweb.Pact5.TransactionExec as Pact5 -import qualified Chainweb.Pact5.Transaction as Pact5 +import Chainweb.Pact5.Backend.ChainwebPactDb qualified as Pact5 +import Chainweb.Pact5.SPV qualified as Pact5 +import Pact.Core.Builtin qualified as Pact5 +import Pact.Core.Persistence qualified as Pact5 +import Pact.Core.Gas qualified as Pact5 +import Pact.Core.Info qualified as Pact5 +import Pact.Core.Command.RPC qualified as Pact5 +import Pact.Core.Command.Types qualified as Pact5 +import Pact.Core.Hash qualified as Pact5 +import Chainweb.Pact5.Types qualified as Pact5 +import Chainweb.Pact.PactService.Pact5.ExecBlock qualified as Pact5 +import Pact.Core.Evaluate qualified as Pact5 +import Pact.Core.Names qualified as Pact5 +import Chainweb.Pact5.TransactionExec qualified as Pact5 +import Chainweb.Pact5.Transaction qualified as Pact5 +import Chainweb.Pact5.NoCoinbase qualified as Pact5 +import Chainweb.Pact5.Validations qualified as Pact5 +import Pact.Core.Errors qualified as Pact5 import Control.Monad.Except import qualified Chainweb.Pact5.NoCoinbase as Pact5 import qualified Pact.Parse as Pact4 @@ -142,7 +153,8 @@ import qualified Pact.Core.Errors as Pact5 import Chainweb.Pact.Backend.Types import qualified Chainweb.Pact.PactService.Checkpointer as Checkpointer import Chainweb.Pact.PactService.Checkpointer (SomeBlockM(..)) - +import Data.Text qualified as T +import Chainweb.Storage.Table (ReadableTable(tableLookup)) runPactService :: Logger logger @@ -381,10 +393,10 @@ serviceRequests memPoolAccess reqQ = go tryOne "syncToBlockBlock" statusRef $ execSyncToBlock _syncToBlockHeader go - ReadOnlyReplayMsg ReadOnlyReplayReq {..} -> do - trace logFn "Chainweb.Pact.PactService.execReadOnlyReplay" (_readOnlyReplayLowerBound, _readOnlyReplayUpperBound) 1 $ - tryOne "readOnlyReplayBlock" statusRef $ - execReadOnlyReplay _readOnlyReplayLowerBound _readOnlyReplayUpperBound + ReplayMsg (ReplayReq target) -> do + trace logFn "Chainweb.Pact.PactService.execReplay" target 1 $ + tryOne "replayBlock" statusRef $ + execReplay target go tryOne @@ -634,13 +646,12 @@ execNewGenesisBlock miner newTrans = pactLabel "execNewGenesisBlock" $ do NoHistory -> internalError "PactService.execNewGenesisBlock: Impossible error, unable to rewind before genesis" Historical block -> return block -execReadOnlyReplay +execReplay :: forall logger tbl . (Logger logger, CanReadablePayloadCas tbl) - => BlockHeader - -> Maybe BlockHeader + => ReplayTarget BlockHeader -> PactServiceM logger tbl () -execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ do +execReplay target = pactLabel "execReplay" $ do ParentHeader cur <- Checkpointer.findLatestValidBlockHeader logger <- view psLogger bhdb <- view psBlockHeaderDb @@ -648,8 +659,9 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ v <- view chainwebVersion cid <- view chainId -- lower bound must be an ancestor of upper. - upperBound <- case maybeUpperBound of - Just upperBound -> do + targetBounds <- case target of + ReplayTargetBlockRange lowerBound (Just upperBound) -> do + liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash upperBound)) >>= flip unless (internalError "lower bound is not an ancestor of upper bound") @@ -657,62 +669,187 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ liftIO (ancestorOf bhdb (view blockHash upperBound) (view blockHash cur)) >>= flip unless (internalError "upper bound is not an ancestor of latest header") - return upperBound - Nothing -> do + return $ Just (lowerBound, upperBound) + ReplayTargetBlockRange lowerBound Nothing -> do liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash cur)) >>= flip unless (internalError "lower bound is not an ancestor of latest header") - return cur - liftIO $ logFunctionText logger Info $ "pact db replaying between blocks " - <> sshow (view blockHeight lowerBound, view blockHash lowerBound) <> " and " - <> sshow (view blockHeight upperBound, view blockHash upperBound) - - let genHeight = genesisHeight v cid - -- we don't want to replay the genesis header in here. - let lowerHeight = max (succ genHeight) (view blockHeight lowerBound) - withPactState $ \runPact -> - liftIO $ getBranchIncreasing bhdb upperBound (int lowerHeight) $ \blocks -> do - heightRef <- newIORef lowerHeight - withAsync (heightProgress lowerHeight (view blockHeight upperBound) heightRef (logInfo_ logger)) $ \_ -> do - blocks - & Stream.hoist liftIO - & play bhdb pdb heightRef runPact + return $ Just (lowerBound, cur) + ReplayTargetTx reqKey@(Pact5.RequestKey (Pact5.unHash -> reqKeySB)) -> do + results <- execLookupPactTxs Nothing (V.singleton reqKeySB) + case results HM.!? reqKeySB of + Just (T2 bheight bhash) -> do + liftIO $ logFunctionText logger Info $ "pact db has transaction " <> sshow reqKey + bh <- liftIO $ fromJuste <$> lookupRanked bhdb (int bheight) bhash + return $ Just (bh, bh) + Nothing -> do + liftIO $ logFunctionText logger Info $ "pact db missing transaction " <> sshow reqKey + return Nothing + + case targetBounds of + Just (lowerBound, upperBound) -> do + + liftIO $ logFunctionText logger Info $ "pact db replaying between blocks " + <> sshow (view blockHeight lowerBound, view blockHash lowerBound) <> " and " + <> sshow (view blockHeight upperBound, view blockHash upperBound) + + let genHeight = genesisHeight v cid + -- we don't want to replay the genesis header in here. + let lowerHeight = max (succ genHeight) (view blockHeight lowerBound) + withPactState $ \runPact -> + liftIO $ getBranchIncreasing bhdb upperBound (int lowerHeight) $ \blocks -> do + heightRef <- newIORef lowerHeight + withAsync (heightProgress lowerHeight (view blockHeight upperBound) heightRef (logInfo_ logger)) $ \_ -> do + blocks + & Stream.hoist liftIO + & play v cid bhdb pdb heightRef runPact + Nothing -> + return () where play :: CanReadablePayloadCas tbl - => BlockHeaderDb + => ChainwebVersion + -> ChainId + -> BlockHeaderDb -> PayloadDb tbl -> IORef BlockHeight -> (forall a. PactServiceM logger tbl a -> IO a) -> Stream.Stream (Stream.Of BlockHeader) IO r -> IO r - play bhdb pdb heightRef runPact blocks = do + play v cid bhdb pdb heightRef runPact blocks = do logger <- runPact $ view psLogger validationFailedRef <- newIORef False r <- blocks & Stream.mapM_ (\bh -> do bhParent <- liftIO $ lookupParentM GenesisParentThrow bhdb bh - let - printValidationError (BlockValidationFailure (BlockValidationFailureMsg m)) = do - writeIORef validationFailedRef True - logFunctionText logger Error m - printValidationError e = throwM e - handleMissingBlock NoHistory = throwM $ BlockHeaderLookupFailure $ - "execReadOnlyReplay: missing block: " <> sshow bh - handleMissingBlock (Historical ()) = return () + + let printValidationError = \case + BlockValidationFailure (BlockValidationFailureMsg m) -> do + writeIORef validationFailedRef True + logFunctionText logger Error m + return (Left ()) + e -> throwM e + + let handleMissingBlock = \case + NoHistory -> throwM $ BlockHeaderLookupFailure $ "execReplay: missing block: " <> sshow bh + Historical x -> return x + payload <- liftIO $ fromJuste <$> lookupPayloadDataWithHeight pdb (Just $ view blockHeight bh) (view blockPayloadHash bh) let isPayloadEmpty = V.null (view payloadDataTransactions payload) let isUpgradeBlock = isJust $ _chainwebVersion bhdb ^? versionUpgrades . atChain (_chainId bhdb) . ix (view blockHeight bh) liftIO $ writeIORef heightRef (view blockHeight bh) - unless (isPayloadEmpty && not isUpgradeBlock) - $ handle printValidationError - $ (handleMissingBlock =<<) - $ runPact - $ Checkpointer.readFrom (Just $ ParentHeader bhParent) $ - SomeBlockM $ Pair - (void $ Pact4.execBlock bh (CheckablePayload payload)) - (void $ Pact5.execExistingBlock bh (CheckablePayload payload)) + unless (isPayloadEmpty && not isUpgradeBlock) $ do + ei <- handle printValidationError + $ fmap Right + $ (handleMissingBlock =<<) + $ runPact + $ Checkpointer.readFrom (Just $ ParentHeader bhParent) $ + SomeBlockM $ Pair + (Pact4.execBlock bh (CheckablePayload payload)) + (error "pact5 lol") -- void $ Pact5.execExistingBlock bh (CheckablePayload payload)) + + case ei of + Left () -> do + return () + Right _ -> do + return () + --(pwo, pact5Dbs) -> do + {- + forM_ (_payloadWithOutputsTransactions pwo) $ \(Transaction txBytes, TransactionOutput txOutBytes) -> do + -- Turn the pact4 tx output into a pact5 one. + -- Converting to and from JSON here is bad for perf, but maybe it doesn't matter, because this test won't exist for long. + cmdResult :: Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)) <- do + let cmdResult4 :: Pact4.CommandResult Pact4.Hash + cmdResult4 = fromJuste $ decodeStrictOrThrow' txOutBytes + decodeStrictOrThrow' (BS.toStrict $ J.encode cmdResult4) + + -- Turn the pact4 tx into a pact5 one + eCmd <- do + -- TODO: Make this transformation not so convoluted... + + -- 1. Decode input bytes as a Pact4 Command + -- TODO: try to parse txBytes into a Pact 5 command directly + let cmd4 :: Pact4.Command Text + cmd4 = fromJuste $ decodeStrictOrThrow' txBytes + + -- 2. Parse the pact4 payload bytes + cmdPayload4 <- case Pact4.decodePayload (pact4ParserVersion v cid (view blockHeight bh)) (Text.encodeUtf8 $ Pact4._cmdPayload cmd4) of + Left err -> internalError $ "execReplay parity: failed to decode pact4 command: " <> sshow err + Right cmdPayload -> return $ fmap Pact4._pcCode cmdPayload + + -- 3. Convert the entire Pact-4 command into a Pact-5 one + let cmd5 = Pact5.fromPact4Command (cmdPayload4 <$ cmd4) + + -- 4. Re-parse the payload. 'fromPact4Command' unfortunately strips the 'Parsed Code' bit. + -- This is ugly as hell. Oh well. + case Pact5._pPayload (Pact5._cmdPayload cmd5 ^. Pact5.payloadObj) of + Pact5.Exec (Pact5.ExecMsg code _data) -> case Pact5.parsePact code of + Left err -> do + return $ Left (err, Pact4.toUntypedHash (Pact4._cmdHash cmd4)) + Right parsedCode -> do + return $ Right $ fmap (fmap (const parsedCode)) cmd5 + Pact5.Continuation _contMsg -> do + -- doesn't do anything but change the type + return $ Right $ fmap (fmap (const (Pact5.ParsedCode "" []))) cmd5 + + case eCmd of + Left (err, reqKey) -> do + let filename = "parity-replay-parse-failures/" Text.unpack (Pact4.hashToText reqKey) <> ".md" + createDirectoryIfMissing True (takeDirectory filename) + Text.writeFile filename $ sshow err + Right cmd -> do + miner <- fromMinerData (_payloadWithOutputsMiner pwo) + let txContext = Pact5.TxContext + { _tcParentHeader = ParentHeader bhParent + , _tcMiner = miner + } + let spvSupport = Pact5.pactSPV bhdb bhParent + let initialGas = Pact5.initialGasOf (Pact5._cmdPayload cmd) + + let toPact4RequestKey :: Pact5.RequestKey -> Pact4.RequestKey + toPact4RequestKey = \case + Pact5.RequestKey (Pact5.Hash bytes) -> Pact4.RequestKey (Pact4.Hash bytes) + let pactDb = pact5Dbs ^?! ix (toPact4RequestKey (Pact5.RequestKey (Pact5._cmdHash cmd))) + + applyCmdResult <- try @_ @SomeException $ Pact5.applyCmd logger Nothing pactDb txContext spvSupport initialGas (fmap (^. Pact5.payloadObj) cmd) + case applyCmdResult of + Left someException -> do + -- TODO: apparently an SPV exception? + -- these exceptions shouldn't happen, do something about it here + logError_ logger $ "Uncaught exception during replay: " <> T.pack (displayException someException) + Right (Left e) -> do + -- uhhhh what do we do here + -- TODO: write all of these out, they should be impossible + logError_ logger $ "Gas buy error during replay: " <> sshow e + Right (Right cmdResult5) -> do + let txMinerId = miner ^. minerId + let r4 = commandResultToDiffable txMinerId cmdResult + let r5 = commandResultToDiffable txMinerId (fmap (Pact5.PELegacyError . Pact5.toPrettyLegacyError) cmdResult5) + when (r4 /= r5) $ do + let requestKey = Pact5.hashToText (Pact5._cmdHash cmd) + + gasLogs <- do + let gasLogsPath = "parity-replay-gas-logs" Text.unpack (Pact5.hashToText (Pact5._cmdHash cmd)) <> ".gaslogs" + (Just <$> Text.readFile gasLogsPath) `catch` \(_ :: IOException) -> return Nothing + + let cwvPathPiece + | v == mainnet = "mainnet" + | v == testnet04 = "testnet" + | otherwise = error "unsupported chainweb version for explorer link" + let explorerLink = "https://explorer.chainweb.com/" <> cwvPathPiece <> "/txdetail/" <> requestKey + let filename = "parity-replay-diffs/" Text.unpack requestKey <> ".md" + + let diffSection = "## Pact4:\n" <> J.encodeText r4 <> "\n\n## Pact5:\n" <> J.encodeText r5 + let explorerLinkSection = "### Explorer link:\n" <> explorerLink + let gasLogsSection = "### Gas logs:\n" <> fromMaybe "No gas logs found." gasLogs + let fullText = diffSection <> "\n\n" <> explorerLinkSection <> "\n\n" <> gasLogsSection + + createDirectoryIfMissing True (takeDirectory filename) + Text.writeFile filename fullText + -} + + return () ) validationFailed <- readIORef validationFailedRef when validationFailed $ diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index 38806cc8b2..000f63a43e 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} @@ -38,6 +39,9 @@ module Chainweb.Pact.PactService.Pact4.ExecBlock , checkParse ) where +import Chainweb.Version.Mainnet (mainnet) +import Chainweb.Version.Testnet04 (testnet04) +import Chainweb.Pact.Types.Parity (CommandResultDiffable(..), commandResultToDiffable) import Chronos qualified import Control.Concurrent.MVar import Control.DeepSeq @@ -51,15 +55,20 @@ import Control.Monad.State.Strict import System.LogLevel (LogLevel(..)) import qualified Data.Aeson as A import qualified Data.ByteString.Short as SB +import Data.ByteString qualified as BS import Data.Decimal import Data.List qualified as List import Data.Either +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory, ()) import Data.Foldable (toList) import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T +import Control.Exception (IOException) import Data.Vector (Vector) import qualified Data.Vector as V @@ -85,6 +94,7 @@ import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Mempool.Mempool as Mempool import Chainweb.Miner.Pact +import Chainweb.TreeDB import Chainweb.Pact.Types import Chainweb.Pact4.SPV qualified as Pact4 @@ -109,8 +119,28 @@ import Chainweb.Pact4.Types import Chainweb.Pact4.ModuleCache import Control.Monad.Except import qualified Data.List.NonEmpty as NE -import Chainweb.Pact.Backend.Types (BlockHandle(..)) - +import Pact.Core.Persistence.Types qualified as Pact5 +import Pact.Core.Builtin qualified as Pact5 +import Pact.Core.Evaluate qualified as Pact5 +import Chainweb.Pact5.Backend.ChainwebPactDb qualified as Pact5 +import Chainweb.Pact5.SPV qualified as Pact5 +import Pact.Core.Builtin qualified as Pact5 +import Pact.Core.Persistence qualified as Pact5 +import Pact.Core.Gas qualified as Pact5 +import Pact.Core.Info qualified as Pact5 +import Pact.Core.Command.RPC qualified as Pact5 +import Pact.Core.Command.Types qualified as Pact5 +import Pact.Core.Hash qualified as Pact5 +import Chainweb.Pact5.Types qualified as Pact5 +import Chainweb.Pact.PactService.Pact5.ExecBlock qualified as Pact5 +import Pact.Core.Evaluate qualified as Pact5 +import Pact.Core.Names qualified as Pact5 +import Chainweb.Pact5.TransactionExec qualified as Pact5 +import Chainweb.Pact5.Transaction qualified as Pact5 +import Chainweb.Pact5.NoCoinbase qualified as Pact5 +import Chainweb.Pact5.Validations qualified as Pact5 +import Pact.Core.Errors qualified as Pact5 +import Chainweb.Pact.Backend.Types -- | Execute a block -- only called in validate either for replay or for validating current block. -- @@ -429,10 +459,10 @@ runCoinbase miner enfCBFail usePrecomp mc = do liftPactServiceM $ logInfoPact "Updating init cache for upgrade" updateInitCacheM newCache - data CommandInvalidError = CommandInvalidGasPurchaseFailure !Pact4GasPurchaseFailure | CommandInvalidTxTimeout !TxTimeout + deriving stock (Show) -- | Apply multiple Pact commands, incrementing the transaction Id for each. -- The output vector is in the same order as the input (i.e. you can zip it @@ -446,31 +476,167 @@ applyPactCmds -> Maybe Micros -> PactBlockM logger tbl (T2 (Vector (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson]))) ModuleCache) applyPactCmds cmds miner startModuleCache blockGas txTimeLimit = do + pactDbEnv <- view (psBlockDbEnv . cpPactDbEnv) + let blockEnvVar = pdPactDbVar pactDbEnv + v <- view chainwebVersion + cid <- view (psServiceEnv . chainId) + logger' <- view (psServiceEnv . psLogger) + blockHeaderDb <- view (psServiceEnv . psBlockHeaderDb) + parentHeader <- view psParentHeader + let spvSupport = Pact5.pactSPV blockHeaderDb (_parentHeader parentHeader) + let txContext = Pact5.TxContext + { _tcParentHeader = parentHeader + , _tcMiner = miner + } + let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to Pact4._crGas) txs + + let go + :: [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])] + -> [Pact4.Transaction] + -> StateT + (T2 ModuleCache (Maybe Pact4.Gas)) + (PactBlockM logger tbl) + [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])] + go !acc = \case + [] -> do + pure acc + tx : rest -> do + let logger = logger' + & addLabel ("blockHeight", sshow (view blockHeight (_parentHeader parentHeader))) + & addLabel ("chainId", chainIdToText cid) + + -- foreach tx + -- 1. save the BlockHandle (which contains pending writes) + -- 2. run the tx with pact5 + -- 3. restore the BlockHandle, discarding all of the writes from pact5 + -- 4. run the tx with pact4 + + -- 1. Get the BlockHandle before running the Pact5 tx + blockEnv <- liftIO $ readMVar blockEnvVar + let blockState = _benvBlockState blockEnv + let blockHandle = BlockHandle (_bsTxId blockState) (_bsPendingBlock blockState) + + -- 2. run the tx with pact5 + eCmd5 <- do + let cmd5' = Pact5.fromPact4Command (fmap (fmap _pcCode) tx) + case Pact5._cmdPayload cmd5' ^. (Pact5.payloadObj . Pact5.pPayload) of + Pact5.Exec (Pact5.ExecMsg code _data) -> do + case Pact5.parsePact code of + Left err -> do + return $ Left (err, Pact5._cmdHash cmd5') + Right parsedCode -> do + return $ Right $ fmap (fmap (const parsedCode)) cmd5' + Pact5.Continuation _ -> do + return $ Right $ fmap (fmap (const (Pact5.ParsedCode "" []))) cmd5' + + mCmdAndResult <- case eCmd5 of + Left (err, reqKey) -> do + let filename = "parity-replay-parse-failures/" T.unpack (Pact5.hashToText reqKey) <> ".md" + liftIO $ do + createDirectoryIfMissing True (takeDirectory filename) + T.writeFile filename $ sshow err + pure Nothing + Right cmd -> do + let initialGas = Pact5.initialGasOf (Pact5._cmdPayload cmd) + let convertTxId (Pact4.TxId txId) = Pact5.TxId txId + let pact5BlockHandlerEnv = Pact5.BlockHandlerEnv + { Pact5._blockHandlerDb = _blockHandlerDb $ _blockHandlerEnv blockEnv + , Pact5._blockHandlerLogger = logger + , Pact5._blockHandlerVersion = v + , Pact5._blockHandlerBlockHeight = view blockHeight (_parentHeader parentHeader) + , Pact5._blockHandlerChainId = _chainId parentHeader + , Pact5._blockHandlerMode = Pact5.Transactional + , Pact5._blockHandlerPersistIntraBlockWrites = _blockHandlerPersistIntraBlockWrites $ _blockHandlerEnv blockEnv + } + let pact5Db = Pact5.chainwebPactBlockDb (Just (view blockHeight (_parentHeader parentHeader), convertTxId (_bsTxId blockState))) pact5BlockHandlerEnv + -- 2. Run the tx with pact5 + -- 3. Discard the writes from pact5 (by ignoring the resulting BlockHandle) + (result, _postPact5blockHandle) <- liftIO $ Pact5.doPact5DbTransaction pact5Db blockHandle (Just (Pact5.RequestKey (Pact5._cmdHash cmd))) $ \pactDb -> do + applyCmdResult <- liftIO $ try @_ @SomeException $ Pact5.applyCmd logger Nothing pactDb txContext spvSupport initialGas (fmap (^. Pact5.payloadObj) cmd) + case applyCmdResult of + Left someException -> do + -- TODO: apparently an SPV exception? + -- these exceptions shouldn't happen, do something about it here + logError_ logger $ "Uncaught exception during replay: " <> T.pack (displayException someException) + pure Nothing + Right (Left e) -> do + -- uhhhh what do we do here + -- TODO: write all of these out, they should be impossible + logError_ logger $ "Gas buy error during replay: " <> sshow e + pure Nothing + Right (Right cmdResult5) -> do + pure $ Just (cmd, cmdResult5) + pure result + + -- Run the pact4 tx + r <- applyPactCmd miner txTimeLimit tx + + case mCmdAndResult of + Nothing -> do + pure () + Just (cmd5, cmdResult5NotRoundripped) -> do + eCmdResult <- do + case r of + Left err -> do + return $ Left err + Right cmdResult4 -> do + Right <$> decodeStrictOrThrow' (BS.toStrict $ J.encode (hashPact4TxLogs cmdResult4)) + -- We have to roundtrip the command result to normalise some things, such as guards, being treated inconsistently + -- as either PGuard or PObject + cmdResult5 <- do + let x :: Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)) + x = hashPact5TxLogs (fmap (Pact5.PELegacyError . Pact5.toPrettyLegacyError) cmdResult5NotRoundripped) + decodeStrictOrThrow' + @_ + @(Pact5.CommandResult A.Value (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info))) + (BS.toStrict $ J.encode x) + case eCmdResult of + Left err -> do + let filename = "parity-replay-result-failures/" T.unpack (Pact5.hashToText (Pact5._cmdHash cmd5)) <> ".md" + liftIO $ do + createDirectoryIfMissing True (takeDirectory filename) + T.writeFile filename $ sshow err + Right (cmdResult :: (Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)))) -> do + let txMinerId = miner ^. minerId + let r4 = commandResultToDiffable txMinerId cmdResult + let r5 = commandResultToDiffable txMinerId cmdResult5 + when (r4 /= r5) $ do + let requestKey = Pact5.hashToText (Pact5._cmdHash cmd5) + + gasLogs <- do + let gasLogsPath = "parity-replay-gas-logs" T.unpack (Pact5.hashToText (Pact5._cmdHash cmd5)) <> ".gaslogs" + liftIO $ (Just <$> T.readFile gasLogsPath) `catch` \(_ :: IOException) -> return Nothing + + let cwvPathPiece + | v == mainnet = "mainnet" + | v == testnet04 = "testnet" + | otherwise = error "unsupported chainweb version for explorer link" + let explorerLink = "https://explorer.chainweb.com/" <> cwvPathPiece <> "/txdetail/" <> requestKey + let filename = "parity-replay-diffs/" T.unpack requestKey <> ".md" + + let diffSection = "## Pact4:\n" <> J.encodeText r4 <> "\n\n## Pact5:\n" <> J.encodeText r5 + let explorerLinkSection = "### Explorer link:\n" <> explorerLink + let gasLogsSection = "### Gas logs:\n" <> fromMaybe "No gas logs found." gasLogs + let locationSection = "### Location:\n" <> "Chain: " <> toText (_chainId parentHeader) <> "\nHeight: " <> toText (succ $ getBlockHeight $ view blockHeight (_parentHeader parentHeader)) + let fullText = diffSection <> "\n\n" <> explorerLinkSection <> "\n\n" <> gasLogsSection <> "\n\n" <> locationSection + + liftIO $ do + createDirectoryIfMissing True (takeDirectory filename) + T.writeFile filename fullText + + case r of + Left e@(CommandInvalidTxTimeout _) -> do + pure (Left e : acc) + Left e@(CommandInvalidGasPurchaseFailure _) -> do + go (Left e : acc) rest + Right a -> do + go (Right a : acc) rest + (txOuts, T2 mcOut _) <- tracePactBlockM' "applyPactCmds" (\_ -> ()) (txsGas . fst) $ - flip runStateT (T2 startModuleCache blockGas) $ - go [] (V.toList cmds) + flip runStateT (T2 startModuleCache blockGas) + $ go [] (V.toList cmds) return $! T2 (V.fromList . List.reverse $ txOuts) mcOut - where - go - :: [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])] - -> [Pact4.Transaction] - -> StateT - (T2 ModuleCache (Maybe Pact4.Gas)) - (PactBlockM logger tbl) - [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])] - go !acc = \case - [] -> do - pure acc - tx : rest -> do - r <- applyPactCmd miner txTimeLimit tx - case r of - Left e@(CommandInvalidTxTimeout _) -> do - pure (Left e : acc) - Left e@(CommandInvalidGasPurchaseFailure _) -> do - go (Left e : acc) rest - Right a -> do - go (Right a : acc) rest applyPactCmd :: (Logger logger) @@ -484,9 +650,9 @@ applyPactCmd applyPactCmd miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do dbEnv <- view psBlockDbEnv let pactDb = _cpPactDbEnv dbEnv - prevBlockState <- liftIO $ fmap _benvBlockState $ - readMVar $ pdPactDbVar pactDb logger <- view (psServiceEnv . psLogger) + + prevBlockState <- liftIO $ fmap _benvBlockState $ readMVar $ pdPactDbVar pactDb gasLogger <- view (psServiceEnv . psGasLogger) txFailuresCounter <- view (psServiceEnv . psTxFailuresCounter) isGenesis <- view psIsGenesis @@ -542,7 +708,7 @@ applyPactCmd miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining txGas (T3 r _ _) = fromIntegral $ Pact4._crGas r T3 r c _warns <- do tracePactBlockM' "applyCmd" (\_ -> J.toJsonViaEncode hsh) txGas $ do - liftIO $ txTimeout $ + liftIO $ txTimeout $ do Pact4.applyCmd v logger gasLogger txFailuresCounter pactDb miner gasModel txCtx spv gasLimitedCmd initialGas mcache ApplySend pure $ T2 r c @@ -630,15 +796,15 @@ validateHashes -> Miner -> Transactions Pact4 (Pact4.CommandResult [Pact4.TxLogJson]) -> Either PactException PayloadWithOutputs -validateHashes bHeader payload miner transactions = - if newHash == prevHash - then Right pwo - else Left $ BlockValidationFailure $ BlockValidationFailureMsg $ - J.encodeText $ J.object - [ "header" J..= J.encodeWithAeson (ObjectEncoded bHeader) - , "mismatch" J..= errorMsg "Payload hash" prevHash newHash - , "details" J..= details - ] +validateHashes bHeader payload miner transactions = Right pwo + -- if newHash == prevHash + -- then Right pwo + -- else Left $ BlockValidationFailure $ BlockValidationFailureMsg $ + -- J.encodeText $ J.object + -- [ "header" J..= J.encodeWithAeson (ObjectEncoded bHeader) + -- , "mismatch" J..= errorMsg "Payload hash" prevHash newHash + -- , "details" J..= details + -- ] where pwo = toPayloadWithOutputs Pact4T miner transactions diff --git a/src/Chainweb/Pact/Service/BlockValidation.hs b/src/Chainweb/Pact/Service/BlockValidation.hs index 9137e762f1..831c302a91 100644 --- a/src/Chainweb/Pact/Service/BlockValidation.hs +++ b/src/Chainweb/Pact/Service/BlockValidation.hs @@ -24,7 +24,7 @@ module Chainweb.Pact.Service.BlockValidation , pactBlockTxHistory , pactHistoricalLookup , pactSyncToBlock -, pactReadOnlyReplay +, pactReplay ) where @@ -105,16 +105,12 @@ lookupPactTxs confDepth txs reqQ = do let !msg = LookupPactTxsMsg req submitRequestAndWait reqQ msg -pactReadOnlyReplay - :: BlockHeader - -> Maybe BlockHeader +pactReplay + :: ReplayTarget BlockHeader -> PactQueue -> IO () -pactReadOnlyReplay l u reqQ = do - let !msg = ReadOnlyReplayMsg ReadOnlyReplayReq - { _readOnlyReplayLowerBound = l - , _readOnlyReplayUpperBound = u - } +pactReplay t reqQ = do + let !msg = ReplayMsg (ReplayReq t) submitRequestAndWait reqQ msg pactPreInsertCheck diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index b3bacc5077..1cf9739b95 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -83,7 +83,8 @@ module Chainweb.Pact.Types , RewindDepth(..) , LocalResult(..) , LocalReq(..) - , ReadOnlyReplayReq(..) + , ReplayReq(..) + , ReplayTarget(..) , ConfirmationDepth(..) , LocalPreflightSimulation(..) , _MetadataValidationFailure @@ -126,7 +127,6 @@ module Chainweb.Pact.Types , RequestCancelled(..) , convertPact5Error - -- * Module cache , ModuleInitCache @@ -903,7 +903,7 @@ data RequestMsg r where BlockTxHistoryMsg :: !BlockTxHistoryReq -> RequestMsg (Historical BlockTxHistory) HistoricalLookupMsg :: !HistoricalLookupReq -> RequestMsg (Historical (Maybe (Pact5.TxLog Pact5.RowData))) SyncToBlockMsg :: !SyncToBlockReq -> RequestMsg () - ReadOnlyReplayMsg :: !ReadOnlyReplayReq -> RequestMsg () + ReplayMsg :: !ReplayReq -> RequestMsg () CloseMsg :: RequestMsg () instance Show (RequestMsg r) where @@ -916,7 +916,7 @@ instance Show (RequestMsg r) where show (BlockTxHistoryMsg req) = show req show (HistoricalLookupMsg req) = show req show (SyncToBlockMsg req) = show req - show (ReadOnlyReplayMsg req) = show req + show (ReplayMsg req) = show req show CloseMsg = "CloseReq" data NewBlockReq @@ -985,13 +985,33 @@ instance Show HistoricalLookupReq where show (HistoricalLookupReq h d k) = "HistoricalLookupReq@" ++ show h ++ ", " ++ show d ++ ", " ++ show k -data ReadOnlyReplayReq = ReadOnlyReplayReq - { _readOnlyReplayLowerBound :: !BlockHeader - , _readOnlyReplayUpperBound :: !(Maybe BlockHeader) +data ReplayTarget b + = ReplayTargetBlockRange + { _replayLowerBound :: !b + , _replayUpperBound :: !(Maybe b) + } + | ReplayTargetTx + { _replayTarget :: !Pact5.RequestKey } -instance Show ReadOnlyReplayReq where - show (ReadOnlyReplayReq l u) = - "ReadOnlyReplayReq@" ++ show l ++ ", " ++ show u + deriving (Eq, Ord, Show) + +instance ToJSON b => ToJSON (ReplayTarget b) where + toJSON (ReplayTargetBlockRange l u) = toJSON [toJSON l, toJSON u] + toJSON (ReplayTargetTx rk) = toJSON $ Pact5.requestKeyToB64Text rk +instance FromJSON b => FromJSON (ReplayTarget b) where + parseJSON v = (withArray "ReplayTargetBounds" $ \arr -> do + [l, u] <- return (V.toList arr) + l' <- parseJSON l + u' <- parseJSON u + return (ReplayTargetBlockRange l' u') + ) v <|> (ReplayTargetTx <$> parseJSON v) + + +data ReplayReq + = ReplayReq (ReplayTarget BlockHeader) +instance Show ReplayReq where + show (ReplayReq t) = + "ReplayReq@" ++ show t data SyncToBlockReq = SyncToBlockReq { _syncToBlockHeader :: !BlockHeader diff --git a/src/Chainweb/Pact/Types/Parity.hs b/src/Chainweb/Pact/Types/Parity.hs new file mode 100644 index 0000000000..95bbc2d3af --- /dev/null +++ b/src/Chainweb/Pact/Types/Parity.hs @@ -0,0 +1,109 @@ +{-# language + DerivingStrategies + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , OverloadedStrings + , RecordWildCards + , ViewPatterns +#-} + +module Chainweb.Pact.Types.Parity + ( CommandResultDiffable(..) + , commandResultToDiffable + ) + where + +import Chainweb.Miner.Pact (MinerId(..)) +import Data.List qualified as List +import Data.Functor (void) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Maybe (fromMaybe) +import Pact.Core.Capabilities qualified as Pact5 +import Pact.Core.Command.Types qualified as Pact5 +import Pact.Core.Errors qualified as Pact5 +import Pact.Core.PactValue qualified as Pact5 +import Pact.Core.Persistence qualified as Pact5 +import Pact.Core.StableEncoding (StableEncoding(..)) +import Pact.JSON.Encode qualified as J + +data CommandResultDiffable = CommandResultDiffable + { -- _crdTxId :: Maybe Pact5.TxId -- TODO: Can't do txId for now + -- TODO: include txlogs, after converting them to the same format + _crdRequestKey :: Pact5.RequestKey + , _crdResult :: Pact5.PactResult ErrorDiffable + , _crdEvents :: OrderedEvents + } + deriving stock (Eq, Show) + +instance J.Encode CommandResultDiffable where + build CommandResultDiffable{..} = J.object + [ --"txId" J..?= fmap (J.Aeson . Pact5._txId) _crdTxId + "requestKey" J..= _crdRequestKey + , "result" J..= _crdResult + , "events" J..= _crdEvents + ] + +newtype OrderedEvents + = OrderedEvents { getOrderedEvents :: Set (StableEncoding (Pact5.PactEvent Pact5.PactValue)) } + deriving stock (Show) + deriving newtype (Eq) + +instance J.Encode OrderedEvents where + build (OrderedEvents s) = J.array s + +newtype ErrorDiffable + = ErrorDiffable (Pact5.PactErrorCompat ()) + deriving stock (Show) + +instance J.Encode ErrorDiffable where + build (ErrorDiffable e) = J.build (fmap J.Array e) + +instance Eq ErrorDiffable where + ErrorDiffable ler == ErrorDiffable rer = diffErr ler rer + where + diffErr (Pact5.PELegacyError l) (Pact5.PELegacyError r) = + Pact5._leType l == Pact5._leType r + diffErr (Pact5.PEPact5Error erc) r = + diffErr (Pact5.PELegacyError $ mkLegacyErrorFromCode erc) r + diffErr l (Pact5.PEPact5Error erc) = + diffErr l (Pact5.PELegacyError $ mkLegacyErrorFromCode erc) + -- We destroy a bit of information whenever we make error codes, so + -- what we can do, is recover what we can, which is the most important bit: + -- the failure cause. We don't really care about the error message, callstack or info + mkLegacyErrorFromCode (Pact5.prettyErrorCode -> e) = + Pact5.LegacyPactError + { Pact5._leType = getLegacyErrType e + , Pact5._leInfo = mempty + , Pact5._leCallStack = [] + , Pact5._leMessage = "" + } + getLegacyErrType e = case Pact5._pecFailurePhase e of + "PEExecutionError" -> case Pact5._pecFailureCause e of + "NativeArgumentsError" -> Pact5.LegacyArgsError + "GasExceeded" -> Pact5.LegacyGasError + "DbOpFailure" -> Pact5.LegacyDbError + "ContinuationError" -> Pact5.LegacyContinuationError + _ -> Pact5.LegacyEvalError + "PEUserRecoverableError" -> Pact5.LegacyTxFailure + "PEParseError" -> Pact5.LegacySyntaxError + "PELexerError" -> Pact5.LegacySyntaxError + "PEDesugarError" -> Pact5.LegacySyntaxError + "PEVerifierError" -> Pact5.LegacyEvalError + _ -> error "impossible: Pact 5 error code generated an illegal error code. This should never happen" + +commandResultToDiffable :: () + => MinerId -- ^ filter out miner + -> Pact5.CommandResult log (Pact5.PactErrorCompat info) + -> CommandResultDiffable +commandResultToDiffable (MinerId minerId) cr = CommandResultDiffable + { -- _crdTxId = Pact5._crTxId cr + _crdRequestKey = Pact5._crReqKey cr + , _crdResult = Pact5._crResult (ErrorDiffable . void <$> cr) + , _crdEvents = OrderedEvents $ Set.fromList $ fmap StableEncoding (List.filter (not . isMinerEvent) (Pact5._crEvents cr)) + } + where + isMinerEvent pe = Pact5.PString minerId `List.elem` Pact5._peArgs pe diff --git a/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs index 3e34ed978e..ad30ee5ecf 100644 --- a/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs @@ -311,7 +311,12 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> KeySets -> lookupWithKey (convKeySetName k) noCache -- TODO: This is incomplete (the modules case), due to namespace -- resolution concerns - Modules -> lookupWithKey (convModuleName mnFix k) checkModuleCache + Modules -> do + v <- lookupWithKey (convModuleName mnFix k) checkModuleCache + -- _ <- forM v $ \m -> do + -- liftIO $ createDirectoryIfMissing True "parity-replay-modules" + -- liftIO $ B.writeFile ("parity-replay-modules" T.unpack (asString k)) $ J.encodeStrict m + pure v Namespaces -> lookupWithKey (convNamespaceName k) noCache (UserTables _) -> lookupWithKey (convRowKey k) noCache Pacts -> lookupWithKey (convPactId k) noCache diff --git a/src/Chainweb/Pact4/TransactionExec.hs b/src/Chainweb/Pact4/TransactionExec.hs index d052dbd423..b401dfb83a 100644 --- a/src/Chainweb/Pact4/TransactionExec.hs +++ b/src/Chainweb/Pact4/TransactionExec.hs @@ -104,6 +104,7 @@ import qualified Data.ByteString.Short as SB import Data.Decimal (Decimal, roundTo) import Data.Foldable (fold, for_, traverse_) import Data.IORef +import qualified Data.HashMap.Strict as HM import qualified Data.List as List import qualified Data.Map.Strict as M import Data.Maybe @@ -371,7 +372,7 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx spv cm chainweb219Pact' = guardCtx chainweb219Pact txCtx chainweb223Pact' = guardCtx chainweb223Pact txCtx allVerifiers = verifiersAt v cid currHeight - toEmptyPactError (PactError errty _ _ _) = PactError errty noInfo [] mempty + toEmptyPactError = id -- (PactError errty _ _ _) = PactError errty noInfo [] mempty toOldListErr pe = pe { peDoc = listErrMsg } isOldListErr = \case diff --git a/src/Chainweb/Pact4/Types.hs b/src/Chainweb/Pact4/Types.hs index 0f49187bb3..a6497fa483 100644 --- a/src/Chainweb/Pact4/Types.hs +++ b/src/Chainweb/Pact4/Types.hs @@ -125,7 +125,7 @@ instance HasChainwebVersion TxContext where -- | Convert context to datatype for Pact environment. -- --- TODO: this should be deprecated, since the `ctxBlockHeader` +-- TODO: this should be deprecated, because the `blockParent` -- call fetches a grandparent, not the parent. -- ctxToPublicData :: TxContext -> PublicData diff --git a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs index b186e9b9d4..eae9c4151c 100644 --- a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs @@ -380,8 +380,8 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> -> BlockHandler logger (Maybe v) lookupWithKey key f checkCache = do pds <- getPendingData "read" - let lookPD = foldr1 (<|>) $ map (lookupInPendingData key f) pds - let lookDB = lookupInDb key f checkCache + let lookPD = asum $ map (lookupInPendingData key f) pds + let lookDB = lookupInDb key checkCache runMaybeT (lookPD <|> lookDB) lookupInPendingData @@ -398,11 +398,10 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> lookupInDb :: forall logger v . - SQ3.Utf8 - -> (BS.ByteString -> Maybe v) + SQ3.Utf8 -> (SQ3.Utf8 -> BS.ByteString -> MaybeT (BlockHandler logger) v) -> MaybeT (BlockHandler logger) v - lookupInDb rowkey _ checkCache = do + lookupInDb rowkey checkCache = do -- First, check: did we create this table during this block? If so, -- there's no point in looking up the key. checkDbTablePendingCreation "read" tablename @@ -423,13 +422,6 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> "doReadRow: Expected (at most) a single result, but got: " <> T.pack (show err) - noCache - :: (BS.ByteString -> Maybe v) - -> SQ3.Utf8 - -> BS.ByteString - -> MaybeT (BlockHandler logger) v - noCache f _key rowdata = MaybeT $ return $! f rowdata - noCacheChargeModuleSize :: (BS.ByteString -> Maybe (Pact.ModuleData Pact.CoreBuiltin Pact.Info)) -> SQ3.Utf8 @@ -439,6 +431,13 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> lift $ BlockHandler $ lift $ lift (Pact.chargeGasM (Pact.GModuleOp (Pact.MOpLoadModule (BS.length rowdata)))) MaybeT $ return $! f rowdata + noCache + :: (BS.ByteString -> Maybe v) + -> SQ3.Utf8 + -> BS.ByteString + -> MaybeT (BlockHandler logger) v + noCache f _key rowdata = MaybeT $ return $! f rowdata + checkDbTablePendingCreation :: Text -> SQ3.Utf8 -> MaybeT (BlockHandler logger) () checkDbTablePendingCreation msg (SQ3.Utf8 tablename) = do @@ -461,8 +460,8 @@ writeSys d k v = do Pact.DModules -> (convModuleName mnFix k, Pact._encodeModuleData Pact.serialisePact_lineinfo v) Pact.DNamespaces -> (convNamespaceName k, Pact._encodeNamespace Pact.serialisePact_lineinfo v) Pact.DDefPacts -> (convPactId k, Pact._encodeDefPactExec Pact.serialisePact_lineinfo v) - Pact.DUserTables _ -> error "impossible" Pact.DModuleSource -> (convHashedModuleName k, Pact._encodeModuleCode Pact.serialisePact_lineinfo v) + Pact.DUserTables _ -> error "impossible" recordPendingUpdate kk (toUtf8 tablename) txid vv recordTxLog d kk vv where @@ -581,12 +580,12 @@ doKeys mlim d = do Just v -> pure v Pact.DNamespaces -> pure $ map Pact.NamespaceName allKeys Pact.DDefPacts -> pure $ map Pact.DefPactId allKeys - Pact.DUserTables _ -> pure $ map Pact.RowKey allKeys Pact.DModuleSource -> do let parsed = map Pact.parseHashedModuleName allKeys case sequence parsed of Just v -> pure v Nothing -> internalDbError $ "doKeys.DModuleSources: unexpected decoding" + Pact.DUserTables _ -> pure $ map Pact.RowKey allKeys where blockLimitStmt = maybe "" (const " WHERE txid < ?;") mlim diff --git a/src/Chainweb/Pact5/Transaction.hs b/src/Chainweb/Pact5/Transaction.hs index d9a8aa8714..8f94f0a87c 100644 --- a/src/Chainweb/Pact5/Transaction.hs +++ b/src/Chainweb/Pact5/Transaction.hs @@ -18,6 +18,7 @@ module Chainweb.Pact5.Transaction , payloadCodec , parseCommand , parsePact4Command + , fromPact4Command ) where import "aeson" Data.Aeson qualified as Aeson diff --git a/src/Chainweb/Pact5/TransactionExec.hs b/src/Chainweb/Pact5/TransactionExec.hs index c0e4b5dbd5..5d0032873a 100644 --- a/src/Chainweb/Pact5/TransactionExec.hs +++ b/src/Chainweb/Pact5/TransactionExec.hs @@ -323,6 +323,8 @@ applyCmd logger maybeGasLogger db txCtx spv initialGas cmd = do , FlagDisableHistoryInTransactionalMode , FlagEnforceKeyFormats , FlagRequireKeysetNs + -- ONLY FOR PARITY REPLAY + , FlagEnableLegacyEventHashes ] let gasLogsEnabled = maybe GasLogsDisabled (const GasLogsEnabled) maybeGasLogger gasEnv <- mkTableGasEnv (MilliGasLimit $ gasToMilliGas $ gasLimit ^. _GasLimit) gasLogsEnabled @@ -434,7 +436,8 @@ ctxToPublicData pm (TxContext ph _) = PublicData BlockHeight !bh = succ $ view blockHeight bheader BlockCreationTime (Time (TimeSpan (Micros !bt))) = view blockCreationTime bheader - BlockHash h = view blockHash bheader + -- PARITY REPLAY ONLY + BlockHash h = view blockParent bheader -- | 'applyCoinbase' performs upgrade transactions and constructs and executes -- a transaction which pays miners their block reward. diff --git a/src/Chainweb/Rosetta/Internal.hs b/src/Chainweb/Rosetta/Internal.hs index 68658a2a6e..5e36ef8cc4 100644 --- a/src/Chainweb/Rosetta/Internal.hs +++ b/src/Chainweb/Rosetta/Internal.hs @@ -49,10 +49,10 @@ 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 Pact.Types.Runtime (TxId(..)) import Rosetta import Servant.Server diff --git a/src/Chainweb/SPV/VerifyProof.hs b/src/Chainweb/SPV/VerifyProof.hs index ee5d3de238..739eb9cfc6 100644 --- a/src/Chainweb/SPV/VerifyProof.hs +++ b/src/Chainweb/SPV/VerifyProof.hs @@ -65,7 +65,7 @@ verifyTransactionProof -> IO Transaction verifyTransactionProof cutDb proof@(TransactionProof cid p) = do unlessM (member cutDb cid h) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed "verifyTransactionProof: target header is not in the chain" proofSubject p where h = runTransactionProof proof @@ -84,7 +84,7 @@ verifyTransactionProofAt -> IO Transaction verifyTransactionProofAt cutDb proof@(TransactionProof cid p) ctx = do unlessM (memberOfM cutDb cid h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed "verifyTransactionProofAt: target header is not in the chain" proofSubject p where h = runTransactionProof proof @@ -103,7 +103,7 @@ verifyTransactionProofAt_ -> IO Transaction verifyTransactionProofAt_ bdb proof@(TransactionProof _cid p) ctx = do unlessM (ancestorOf bdb h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed "verifyTransactionProofAt_: target header is not in the chain" proofSubject p where h = runTransactionProof proof @@ -128,7 +128,7 @@ verifyTransactionOutputProof -> IO TransactionOutput verifyTransactionOutputProof cutDb proof@(TransactionOutputProof cid p) = do unlessM (member cutDb cid h) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed "verifyTransactionOutputProof_: target header is not in the chain" proofSubject p where h = runTransactionOutputProof proof @@ -147,7 +147,7 @@ verifyTransactionOutputProofAt -> IO TransactionOutput verifyTransactionOutputProofAt cutDb proof@(TransactionOutputProof cid p) ctx = do unlessM (memberOfM cutDb cid h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed "verifyTransactionOutputProofAt: target header is not in the chain" proofSubject p where h = runTransactionOutputProof proof @@ -166,7 +166,7 @@ verifyTransactionOutputProofAt_ -> IO TransactionOutput verifyTransactionOutputProofAt_ bdb proof@(TransactionOutputProof _cid p) ctx = do unlessM (ancestorOf bdb h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed "verifyTransactionOutputProofAt_: target header is not in the chain" proofSubject p where h = runTransactionOutputProof proof diff --git a/src/Chainweb/Version.hs b/src/Chainweb/Version.hs index 5bff5af741..a37bd3230c 100644 --- a/src/Chainweb/Version.hs +++ b/src/Chainweb/Version.hs @@ -87,6 +87,15 @@ module Chainweb.Version , pattern ForPact5 , forAnyPactVersion + , PactUpgrade(..) + , PactVersion(..) + , PactVersionT(..) + , ForBothPactVersions(..) + , ForSomePactVersion(..) + , pattern ForPact4 + , pattern ForPact5 + , forAnyPactVersion + -- * Typelevel ChainwebVersionName , ChainwebVersionT(..) , ChainwebVersionSymbol diff --git a/src/Chainweb/Version/Registry.hs b/src/Chainweb/Version/Registry.hs index 2f11d5ea66..590746dbfe 100644 --- a/src/Chainweb/Version/Registry.hs +++ b/src/Chainweb/Version/Registry.hs @@ -129,7 +129,6 @@ lookupVersionByCode code -- the case that we don't actually need the version, just the code. lookupVersion & versionCode .~ code where - lookupVersion :: HasCallStack => ChainwebVersion lookupVersion = unsafeDupablePerformIO $ do m <- readIORef versionMap diff --git a/src/Chainweb/WebPactExecutionService.hs b/src/Chainweb/WebPactExecutionService.hs index 7fc3cc14f4..cfcd2a770d 100644 --- a/src/Chainweb/WebPactExecutionService.hs +++ b/src/Chainweb/WebPactExecutionService.hs @@ -113,9 +113,9 @@ data PactExecutionService = PactExecutionService -- txs to lookup -> IO (HM.HashMap ShortByteString (T2 BlockHeight BlockHash)) ) - , _pactReadOnlyReplay :: !( - BlockHeader -> - Maybe BlockHeader -> + , _pactReplay :: !( + ChainId -> + ReplayTarget BlockHeader -> IO () ) -- ^ Lookup pact hashes as of a block header to detect duplicates @@ -197,7 +197,7 @@ mkWebPactExecutionService hm = WebPactExecutionService $ PactExecutionService , _pactBlockTxHistory = \h d -> withChainService (_chainId h) $ \p -> _pactBlockTxHistory p h d , _pactHistoricalLookup = \h d k -> withChainService (_chainId h) $ \p -> _pactHistoricalLookup p h d k , _pactSyncToBlock = \h -> withChainService (_chainId h) $ \p -> _pactSyncToBlock p h - , _pactReadOnlyReplay = \l u -> withChainService (_chainId l) $ \p -> _pactReadOnlyReplay p l u + , _pactReplay = \cid t -> withChainService cid $ \p -> _pactReplay p cid t } where withChainService cid act = maybe (err cid) act $ HM.lookup cid hm @@ -226,7 +226,7 @@ mkPactExecutionService q = PactExecutionService , _pactHistoricalLookup = \h d k -> pactHistoricalLookup h d k q , _pactSyncToBlock = \h -> pactSyncToBlock h q - , _pactReadOnlyReplay = \l u -> pactReadOnlyReplay l u q + , _pactReplay = \_cid t -> pactReplay t q } -- | A mock execution service for testing scenarios. Throws out anything it's @@ -243,5 +243,5 @@ emptyPactExecutionService = PactExecutionService , _pactBlockTxHistory = \_ _ -> error "Chainweb.WebPactExecutionService.emptyPactExecutionService: pactBlockTxHistory unsupported" , _pactHistoricalLookup = \_ _ _ -> error "Chainweb.WebPactExecutionService.emptyPactExecutionService: pactHistoryLookup unsupported" , _pactSyncToBlock = \_ -> return () - , _pactReadOnlyReplay = \_ _ -> return () + , _pactReplay = \_ _ -> return () } diff --git a/src/P2P/Node/Configuration.hs b/src/P2P/Node/Configuration.hs index 5228065663..cdb9357eb4 100644 --- a/src/P2P/Node/Configuration.hs +++ b/src/P2P/Node/Configuration.hs @@ -131,17 +131,17 @@ validateP2pConfiguration :: Applicative a => ConfigValidation P2pConfiguration a validateP2pConfiguration c = do validatePeerConfig $ _p2pConfigPeer c - when (null (_p2pConfigKnownPeers c)) $ do - if _p2pConfigPrivate c && _p2pConfigIgnoreBootstrapNodes c - then tell $ pure "This node is configured to not communicate with any other nodes, including bootstrap nodes." + -- when (null (_p2pConfigKnownPeers c)) $ do + -- if _p2pConfigPrivate c && _p2pConfigIgnoreBootstrapNodes c + -- then tell $ pure "This node is configured to not communicate with any other nodes, including bootstrap nodes." - else if _p2pConfigPrivate c - then tell $ pure "This node is configured to communicate only with the default bootstrap nodes." + -- else if _p2pConfigPrivate c + -- then tell $ pure "This node is configured to communicate only with the default bootstrap nodes." - else if _p2pConfigIgnoreBootstrapNodes c - then tell $ pure "Default bootstrap nodes are ignored and no known peers are configured. This node won't be able to communicate with the network." + -- else if _p2pConfigIgnoreBootstrapNodes c + -- then tell $ pure "Default bootstrap nodes are ignored and no known peers are configured. This node won't be able to communicate with the network." - else return () + -- else return () validateRange "sessionTimeout" (60 {- 1 min -}, 900 {- 15 min -}) (_p2pConfigSessionTimeout c) diff --git a/test/lib/Chainweb/Test/MultiNode.hs b/test/lib/Chainweb/Test/MultiNode.hs index d825d3f974..f0fa46bbbf 100644 --- a/test/lib/Chainweb/Test/MultiNode.hs +++ b/test/lib/Chainweb/Test/MultiNode.hs @@ -221,7 +221,9 @@ harvestConsensusState -> Int -> StartedChainweb logger -> IO () -harvestConsensusState _ _ _ (Replayed _ _) = +harvestConsensusState _ _ _ (ReadOnlyReplayed _) = + error "harvestConsensusState: doesn't work when replaying, replays don't do consensus" +harvestConsensusState _ _ _ (Rewound _ _) = error "harvestConsensusState: doesn't work when replaying, replays don't do consensus" harvestConsensusState logger stateVar nid (StartedChainweb cw) = do runChainweb cw (\_ -> return ()) `finally` do @@ -251,7 +253,8 @@ multiNode loglevel write bootstrapPeerInfoVar conf rdb pactDbDir nid inner = do StartedChainweb cw' -> when (nid == 0) $ putMVar bootstrapPeerInfoVar $ view (chainwebPeer . peerResPeer . peerInfo) cw' - Replayed _ _ -> return () + Rewound _ _ -> return () + ReadOnlyReplayed _ -> return () inner nid cw where logger :: GenericLogger @@ -594,7 +597,7 @@ replayTest loglevel v n rdb pactDbDir step = do & set (configCuts . cutInitialBlockHeightLimit) (Just replayInitialHeight) & set configOnlySyncPact True) n (Seconds 20) rdb pactDbDir $ \nid cw -> case cw of - Replayed l (Just u) -> do + Rewound l (Just u) -> do writeIORef firstReplayCompleteRef True _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh -> assertEqual ("lower chain " <> sshow cid) replayInitialHeight (view blockHeight bh) @@ -604,7 +607,7 @@ replayTest loglevel v n rdb pactDbDir step = do _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh -> assertGe ("upper chain " <> sshow cid) (Actual $ view blockHeight bh) (Expected replayInitialHeight) return () - Replayed _ Nothing -> error "replayTest: no replay upper bound" + Rewound _ Nothing -> error "replayTest: no replay upper bound" _ -> error "replayTest: not a replay" assertEqual "first replay completion" True =<< readIORef firstReplayCompleteRef let fastForwardHeight = 10 @@ -616,14 +619,14 @@ replayTest loglevel v n rdb pactDbDir step = do & set (configCuts . cutFastForwardBlockHeightLimit) (Just fastForwardHeight) & set configOnlySyncPact True) n (Seconds 20) rdb pactDbDir $ \_ cw -> case cw of - Replayed l (Just u) -> do + Rewound l (Just u) -> do writeIORef secondReplayCompleteRef True _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh -> assertEqual ("lower chain " <> sshow cid) replayInitialHeight (view blockHeight bh) _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh -> assertEqual ("upper chain " <> sshow cid) fastForwardHeight (view blockHeight bh) return () - Replayed _ Nothing -> do + Rewound _ Nothing -> do error "replayTest: no replay upper bound" _ -> error "replayTest: not a replay" assertEqual "second replay completion" True =<< readIORef secondReplayCompleteRef diff --git a/test/lib/Chainweb/Test/Pact4/Utils.hs b/test/lib/Chainweb/Test/Pact4/Utils.hs index 4ce86ef50b..8bdfe02eb3 100644 --- a/test/lib/Chainweb/Test/Pact4/Utils.hs +++ b/test/lib/Chainweb/Test/Pact4/Utils.hs @@ -774,8 +774,8 @@ withWebPactExecutionServiceCompaction logger v pactConfig bdb mempools act = evalPactServiceM_ ctx $ execHistoricalLookup h d k , _pactSyncToBlock = \h -> evalPactServiceM_ ctx $ execSyncToBlock h - , _pactReadOnlyReplay = \l u -> - evalPactServiceM_ ctx $ execReadOnlyReplay l u + , _pactReplay = \_cid t -> + evalPactServiceM_ ctx $ execReplay t } -- | A queue-less WebPactExecutionService (for all chains) @@ -824,8 +824,8 @@ withWebPactExecutionService logger v pactConfig bdb mempools act = evalPactServiceM_ ctx $ execHistoricalLookup h d k , _pactSyncToBlock = \h -> evalPactServiceM_ ctx $ execSyncToBlock h - , _pactReadOnlyReplay = \l u -> - evalPactServiceM_ ctx $ execReadOnlyReplay l u + , _pactReplay = \_cid t -> + evalPactServiceM_ ctx $ execReplay t } -- | Noncer for 'runCut' diff --git a/test/lib/Chainweb/Test/Utils.hs b/test/lib/Chainweb/Test/Utils.hs index 36a958cff1..086eaa65c3 100644 --- a/test/lib/Chainweb/Test/Utils.hs +++ b/test/lib/Chainweb/Test/Utils.hs @@ -1059,7 +1059,8 @@ node rdb rawLogger nowServingRef peerInfoVar conf pactDbDir backupDir nid = do logFunctionText logger Info "write sample data" logFunctionText logger Info "shutdown node" return () - Replayed _ _ -> error "node: should not be a replay" + ReadOnlyReplayed _ -> error "node: should not be a replay" + Rewound _ _ -> error "node: should not be a replay" where logger = addLabel ("node", sshow nid) rawLogger diff --git a/test/unit/Chainweb/Test/CutDB.hs b/test/unit/Chainweb/Test/CutDB.hs index d1fa8aa936..9da2e7f155 100644 --- a/test/unit/Chainweb/Test/CutDB.hs +++ b/test/unit/Chainweb/Test/CutDB.hs @@ -505,7 +505,7 @@ fakePact = WebPactExecutionService $ PactExecutionService , _pactBlockTxHistory = \_ _ -> error "Unimplemented" , _pactHistoricalLookup = \_ _ _ -> error "Unimplemented" , _pactSyncToBlock = \_ -> error "Unimplemented" - , _pactReadOnlyReplay = \_ _ -> error "Unimplemented" + , _pactReplay = \_ _ -> error "Unimplemented" } where getFakeOutput (Transaction txBytes) = TransactionOutput txBytes diff --git a/unchecked-diff-classes b/unchecked-diff-classes new file mode 100644 index 0000000000..b86ed381b4 --- /dev/null +++ b/unchecked-diff-classes @@ -0,0 +1,32 @@ +gas-exceeded +keyset-failure +no-such-member +loaded-module-hash +minimum-precision +lago-finance +expected-bool-got-unit +capability-already-installed +output-differs-int-double +cap-is-not-managed +kadena-mining-club +cannot-find-module +no-pact-exec-in-cr +interface-loaded +keyset-defined +desugar-syntax-failure +invalid-call-to-if +db-internal-error +b64-diffs +invalid-def-in-term-var +marmalade-mints +marmalade-v2 +too-many-arguments +read-keyset-error +read-function-failures +interface-impl-errors +list-commas +interface-as-mod-ref +nft-mint-mystery +module-admin +sort-object-divergence +incompatible-types diff --git a/unclassify-diffs b/unclassify-diffs new file mode 100755 index 0000000000..79c58ad6c6 --- /dev/null +++ b/unclassify-diffs @@ -0,0 +1,3 @@ +#!/usr/bin/env sh + +find diffs/ -type f -exec mv -t parity-replay-diffs/ {} +