diff --git a/gasmodel/Pact/Core/GasModel/BuiltinsGas.hs b/gasmodel/Pact/Core/GasModel/BuiltinsGas.hs index 46e01ed4..49043e05 100644 --- a/gasmodel/Pact/Core/GasModel/BuiltinsGas.hs +++ b/gasmodel/Pact/Core/GasModel/BuiltinsGas.hs @@ -921,6 +921,11 @@ benchesForBuiltin bn = case bn of CoreHyperlaneEncodeMessage -> todo CoreHyperlaneMessageId -> todo CoreStaticRedeploy -> omittedDeliberately + -- Note: Hash-poseidon is an alias to the poseidon-hash-hackachain + -- function, so we don't need benches for it + CoreHashPoseidon -> omittedDeliberately + -- TODO: port keccak benchmarks + CoreHashKeccak256 -> omittedDeliberately where omittedDeliberately = const [] alreadyCovered = const [] @@ -955,7 +960,7 @@ benchmarks = C.envWithCleanup mkPactDb cleanupPactDb $ \ ~(pdb, _, _) -> do ] where mkPactDb = do - (pdb, db, cache) <- unsafeCreateSqlitePactDb serialisePact_lineinfo ":memory:" + (pdb, db, cache) <- unsafeCreateSqlitePactDb serialisePact_lineinfo_pact51 ":memory:" pure (pdb, NoNf db, NoNf cache) cleanupPactDb (_, NoNf db, NoNf cache) = unsafeCloseSqlitePactDb db cache diff --git a/gasmodel/Pact/Core/GasModel/ContractBench.hs b/gasmodel/Pact/Core/GasModel/ContractBench.hs index 2108c4e2..560872a3 100644 --- a/gasmodel/Pact/Core/GasModel/ContractBench.hs +++ b/gasmodel/Pact/Core/GasModel/ContractBench.hs @@ -194,7 +194,7 @@ setupCoinTxs pdb = do _run :: IO () _run = do - pdb <- mockPactDb serialisePact_lineinfo + pdb <- mockPactDb serialisePact_lineinfo_pact51 setupCoinTxs pdb >>= print coinTransferTxRaw :: Text -> Text -> Text @@ -427,7 +427,7 @@ allBenchmarks = do -- , runPureBench "Let 10000" (deepLetTXRaw 10000) pdb interpretBigStep ] mkPactDb = do - pdb <- mockPactDb serialisePact_lineinfo + pdb <- mockPactDb serialisePact_lineinfo_pact51 _ <- ignoreGas def $ _pdbBeginTx pdb Transactional _ <- setupCoinTxs pdb _ <- ignoreGas def $ _pdbCommitTx pdb diff --git a/gasmodel/Pact/Core/GasModel/ModuleLoadBench.hs b/gasmodel/Pact/Core/GasModel/ModuleLoadBench.hs index 0e112306..03a6121c 100644 --- a/gasmodel/Pact/Core/GasModel/ModuleLoadBench.hs +++ b/gasmodel/Pact/Core/GasModel/ModuleLoadBench.hs @@ -60,11 +60,11 @@ genModules w = sizeOfVsSize :: IO [(Int, Int)] sizeOfVsSize = do let modules = genModules 42020 - pdb <- mockPactDb serialisePact_lineinfo + pdb <- mockPactDb serialisePact_lineinfo_pact51 ee <- setupBenchEvalEnv pdb mempty PUnit out <- runEvalMResult (ExecEnv ee) def $ forM modules $ \m -> do sz <- sizeOfInternal m - let bs = _encodeModuleData serialisePact_lineinfo m + let bs = _encodeModuleData serialisePact_lineinfo_pact51 m pure (fromIntegral sz, B.length bs) either (error . show) pure out where @@ -109,7 +109,7 @@ runModuleLoadBench pdb i = title bs = let bs' = T.pack (show bs) in T.unpack [text| Benching module of size (in bytes), ${bs'} |] - bytesize mdata = B.length $ _encodeModuleData serialisePact_lineinfo mdata + bytesize mdata = B.length $ _encodeModuleData serialisePact_lineinfo_pact51 mdata mkModule = do let mdata = genModule (42020 + fromIntegral i) _ <- ignoreGas def $ _pdbBeginTx pdb Transactional @@ -127,7 +127,7 @@ benchmarks = C.env mkPdb $ \ ~(pdb) -> C.bgroup "Module load benches" (runModuleLoadBench pdb <$> [1..1]) where mkPdb = do - pdb <- mockPactDb serialisePact_lineinfo + pdb <- mockPactDb serialisePact_lineinfo_pact51 _ <- ignoreGas def $ _pdbBeginTx pdb Transactional _ <- ignoreGas def $ _pdbCommitTx pdb pure pdb diff --git a/pact-repl/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs b/pact-repl/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs index 2b60a1a1..4066752a 100644 --- a/pact-repl/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs +++ b/pact-repl/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs @@ -83,6 +83,7 @@ import Pact.Core.Namespace #ifndef WITHOUT_CRYPTO import Pact.Core.Crypto.Pairing import Pact.Core.Crypto.Hash.Poseidon +import Pact.Core.Crypto.Hash.Keccak256 #endif import Pact.Core.SizeOf @@ -1895,10 +1896,23 @@ poseidonHash info b _env = \case [VList as] | not (V.null as) && length as <= 8, Just intArgs <- traverse (preview (_PLiteral . _LInteger)) as -> do - chargeGasArgs info (GPoseidonHashHackAChain (length intArgs)) + chargeGasArgs info (GHashOp (GHashPoseidon (length intArgs))) return $ VInteger (poseidon (V.toList intArgs)) args -> argsError info b args +coreHashKeccak256 :: (IsBuiltin b) => NativeFunction e b i +coreHashKeccak256 info b _env = \case + [VList li] -> do + texts <- traverse (asString info b) li + let chunkBytes = V.map (BS.length . T.encodeUtf8) texts + chargeGasArgs info (GHashOp (GHashKeccak chunkBytes)) + output <- case keccak256 texts of + Left keccakErr -> throwExecutionError info (Keccak256Error keccakErr) + Right output -> pure output + return (VString output) + args -> argsError info b args + + #else zkPairingCheck :: (IsBuiltin b) => NativeFunction e b i @@ -1913,6 +1927,9 @@ zkPointAddition info _b _env _args = throwExecutionError info $ EvalError $ "cry poseidonHash :: (IsBuiltin b) => NativeFunction e b i poseidonHash info _b _env _args = throwExecutionError info $ EvalError $ "crypto disabled" +coreHashKeccak256 :: (IsBuiltin b) => NativeFunction e b i +coreHashKeccak256 info _b _env _args = throwExecutionError info $ EvalError $ "crypto disabled" + #endif ----------------------------------- @@ -2201,3 +2218,5 @@ coreBuiltinRuntime = CoreReadWithFields -> dbRead CoreListModules -> coreListModules CoreStaticRedeploy -> coreStaticRedeploy + CoreHashPoseidon -> poseidonHash + CoreHashKeccak256 -> coreHashKeccak256 diff --git a/pact-request-api/Pact/Core/Command/Server/History.hs b/pact-request-api/Pact/Core/Command/Server/History.hs index 8f9280f0..1af04489 100644 --- a/pact-request-api/Pact/Core/Command/Server/History.hs +++ b/pact-request-api/Pact/Core/Command/Server/History.hs @@ -48,7 +48,7 @@ withSqliteAndHistoryDb path act = close (_, _, db, stmt) = liftIO $ unsafeCloseSqlitePactDb db stmt open = do - (pdb, db, stmt) <- unsafeCreateSqlitePactDb serialisePact_lineinfo path + (pdb, db, stmt) <- unsafeCreateSqlitePactDb serialisePact_lineinfo_pact51 path liftIO $ SQL.exec db createHistoryTblStmt pure (pdb, dbToHistDb db, db, stmt) diff --git a/pact-tests/Pact/Core/Test/GasGolden.hs b/pact-tests/Pact/Core/Test/GasGolden.hs index 7c89769d..37a56a51 100644 --- a/pact-tests/Pact/Core/Test/GasGolden.hs +++ b/pact-tests/Pact/Core/Test/GasGolden.hs @@ -16,6 +16,7 @@ import Pact.Core.Repl import Pact.Core.Repl.Compile import Pact.Core.Repl.Utils import Pact.Core.Serialise +import Pact.Core.Evaluate(versionedNatives) import System.Directory import System.FilePath import Test.Tasty @@ -35,16 +36,22 @@ tests = do cases <- gasTestFiles pure $ testGroup "Gas Goldens" [ testCase "Capture all builtins" $ captureBuiltins (fst <$> cases) - , goldenVsStringDiff "Gas Goldens: CEK" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretEvalBigStep) - , goldenVsStringDiff "Gas Goldens: Direct" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretEvalDirect) + , goldenVsStringDiff "Gas Goldens, Pact 5.0: CEK" runDiff (gasGoldenOutputDir "builtinGas50.golden") (pact50Goldens cases interpretEvalBigStep) + , goldenVsStringDiff "Gas Goldens, Pact 5.0: Direct" runDiff (gasGoldenOutputDir "builtinGas50.golden") (pact50Goldens cases interpretEvalDirect) + , goldenVsStringDiff "Gas Goldens, Pact Latest: CEK" runDiff (gasGoldenOutputDir "builtinGas.golden") (gasGoldenTests cases interpretEvalBigStep) + , goldenVsStringDiff "Gas Goldens, Pact Latest: Direct" runDiff (gasGoldenOutputDir "builtinGas.golden") (gasGoldenTests cases interpretEvalDirect) ] where + pact50Goldens cases interp = gasGoldenTestsWithFlags (S.singleton FlagDisablePact51) cases interp runDiff = \ref new -> ["diff", "-u", ref, new] gasTestDir :: [Char] gasTestDir = "pact-tests" "gas-goldens" +gasGoldenOutputDir :: [Char] +gasGoldenOutputDir = "pact-tests" "gas-goldens" "goldens" + gasTestFiles :: IO [(Text, FilePath)] gasTestFiles = do @@ -66,10 +73,17 @@ captureBuiltins b = let lookupOp :: Text -> Text lookupOp n = fromMaybe n (M.lookup n fileNameToOp) +lookupFileNameOp :: Text -> Text +lookupFileNameOp n = fromMaybe n (M.lookup n opToFileName) gasGoldenTests :: [(Text, FilePath)] -> ReplInterpreter -> IO BS.ByteString -gasGoldenTests c interp = do - gasOutputs <- forM c $ \(fn, fp) -> do +gasGoldenTests = gasGoldenTestsWithFlags mempty + +gasGoldenTestsWithFlags :: S.Set ExecutionFlag -> [(Text, FilePath)] -> ReplInterpreter -> IO BS.ByteString +gasGoldenTestsWithFlags flags natives interp = do + let enabledNatives = S.fromList $ fmap lookupFileNameOp $ M.keys $ versionedNatives flags + let filteredTestsToRun = filter ((`S.member` enabledNatives) . fst) natives + gasOutputs <- forM filteredTestsToRun $ \(fn, fp) -> do mGas <- runGasTest (gasTestDir fp) interp case mGas of Nothing -> fail $ "Could not execute the gas tests for: " <> show fp diff --git a/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs b/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs index bc420562..3bac2946 100644 --- a/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs +++ b/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs @@ -78,4 +78,4 @@ legacyTests = do where toModuleData p fp = - decodeModuleData <$> BS.readFile (legacyTestDir p fp) + decodeModuleData LegacyKeccakPatchDisabled <$> BS.readFile (legacyTestDir p fp) diff --git a/pact-tests/Pact/Core/Test/PactServerTests.hs b/pact-tests/Pact/Core/Test/PactServerTests.hs index ff891762..224ee4fd 100644 --- a/pact-tests/Pact/Core/Test/PactServerTests.hs +++ b/pact-tests/Pact/Core/Test/PactServerTests.hs @@ -73,7 +73,7 @@ tests = withResource ] where mkEnv = do - (pdb,db,stmt) <- unsafeCreateSqlitePactDb serialisePact_lineinfo ":memory:" + (pdb,db,stmt) <- unsafeCreateSqlitePactDb serialisePact_lineinfo_pact51 ":memory:" (histDb, db') <- unsafeCreateHistoryDb ":memory:" chan <- newChan let diff --git a/pact-tests/Pact/Core/Test/PersistenceTests.hs b/pact-tests/Pact/Core/Test/PersistenceTests.hs index db91253a..9fe699d0 100644 --- a/pact-tests/Pact/Core/Test/PersistenceTests.hs +++ b/pact-tests/Pact/Core/Test/PersistenceTests.hs @@ -112,7 +112,7 @@ namespaceRoundtrip serial builtins = property $ do -- contain the expected metadata. sqliteRegression :: TestTree sqliteRegression = withResource - (unsafeCreateSqlitePactDb serialisePact_lineinfo ":memory:") + (unsafeCreateSqlitePactDb serialisePact_lineinfo_pact51 ":memory:") (\(_, db, stmtcache) -> unsafeCloseSqlitePactDb db stmtcache) $ \db -> testCase "Sqlite Db regression" @@ -120,4 +120,4 @@ sqliteRegression = withResource pureDbRegression :: TestTree pureDbRegression = testCase "PureDb regression" - (runPactDbRegression =<< mockPactDb serialisePact_lineinfo) + (runPactDbRegression =<< mockPactDb serialisePact_lineinfo_pact51) diff --git a/pact-tests/constructor-tag-goldens/CoreBuiltin.golden b/pact-tests/constructor-tag-goldens/CoreBuiltin.golden index 8c3c0701..8ba27d1f 100644 --- a/pact-tests/constructor-tag-goldens/CoreBuiltin.golden +++ b/pact-tests/constructor-tag-goldens/CoreBuiltin.golden @@ -134,4 +134,6 @@ {"conName":"CoreReadWithFields","conIndex":"85"} {"conName":"CoreListModules","conIndex":"86"} {"conName":"CoreStaticRedeploy","conIndex":"87"} +{"conName":"CoreHashKeccak256","conIndex":"88"} +{"conName":"CoreHashPoseidon","conIndex":"89"} diff --git a/pact-tests/constructor-tag-goldens/EvalError.golden b/pact-tests/constructor-tag-goldens/EvalError.golden index 487588d3..3e8e328c 100644 --- a/pact-tests/constructor-tag-goldens/EvalError.golden +++ b/pact-tests/constructor-tag-goldens/EvalError.golden @@ -75,4 +75,5 @@ {"conName":"UnknownException","conIndex":"4a"} {"conName":"InvalidNumArgs","conIndex":"4b"} {"conName":"EntityNotAllowedInDefPact","conIndex":"4c"} +{"conName":"Keccak256Error","conIndex":"4d"} diff --git a/pact-tests/gas-goldens/builtinGas.golden b/pact-tests/gas-goldens/builtinGas.golden deleted file mode 100644 index 2aff9014..00000000 --- a/pact-tests/gas-goldens/builtinGas.golden +++ /dev/null @@ -1,124 +0,0 @@ -!=: 201 -&: 250 -*: 127 -+: 130 --: 130 -/: 127 -<: 264 -<=: 264 -=: 201 ->: 264 ->=: 264 -^: 868 -abs: 100 -acquire-module-admin: 295598 -add-time: 750 -and?: 628 -at: 706 -base64-decode: 331 -base64-encode: 311 -bind: 477 -ceiling: 200 -chain-data: 500 -compose-capability: 514500 -compose: 2760 -concat: 820 -cond: 602 -contains: 405 -continue: 441150 -create-capability-guard: 227750 -create-capability-pact-guard: 246700 -create-module-guard: 188100 -create-pact-guard: 209850 -create-principal: 2002 -create-table: 466600 -days: 278 -dec: 100 -define-keyset: 8404 -define-namespace: 43812 -describe-keyset: 108404 -describe-module: 262700 -describe-namespace: 149724 -describe-table: 566600 -diff-time: 1414 -distinct: 2176 -drop: 1000 -emit-event: 263650 -enforce-guard: 3166 -enforce-keyset: 3166 -enforce-verifier: 10150 -enumerate: 524 -exp: 4534 -filter: 2760 -floor: 200 -fold-db: 40500850 -fold: 1090 -format-time: 1041 -format: 1900 -hash: 3500 -hours: 277 -hyperlane-decode-token-message: 2175 -hyperlane-encode-token-message: 2475 -hyperlane-message-id: 2743 -identity: 100 -insert: 500650 -install-capability: 670289 -int-to-str: 800 -is-charset: 1788 -is-principal: 597 -keys: 40500650 -keyset-ref-guard: 10425 -length: 801 -list-modules: 100000 -ln: 2016 -log: 2090 -make-list: 125 -map: 1315 -minutes: 276 -mod: 100 -namespace: 43824 -negate: 100 -not: 364 -not?: 364 -or?: 364 -pact-id: 225850 -pairing-check: 12003058 -parse-time: 602 -point-add: 5500 -poseidon-hash-hack-a-chain: 6393700 -read-decimal: 303 -read-integer: 303 -read-keyset: 8608 -read-msg: 303 -read-string: 303 -read: 507550 -remove: 360 -require-capability: 402750 -resume: 515256 -reverse: 700 -round: 200 -scalar-mult: 360300 -select: 40500800 -shift: 886 -show: 1300 -sort: 1200 -sqrt: 2022 -static-redeploy: 298800 -str-to-int: 408 -str-to-list: 751 -take: 1800 -time: 500 -tx-hash: 100 -typeof-principal: 797 -typeof: 100 -update: 534750 -validate-principal: 3940 -where: 1640 -with-default-read: 510816 -with-read: 507733 -write: 500650 -xor: 500 -yield: 328075 -zip: 4320 -|: 500 -~: 250 \ No newline at end of file diff --git a/pact-tests/pact-tests/hash.repl b/pact-tests/pact-tests/hash.repl index 5cf87f17..5e429f95 100644 --- a/pact-tests/pact-tests/hash.repl +++ b/pact-tests/pact-tests/hash.repl @@ -48,3 +48,27 @@ (expect "hashes match post-fork - recursive case" true (enforce (= h1 h2) "boom")) ) (commit-tx) + +; Keccak hash tests +(begin-tx) + +(defun hash-keccak (arg) + (int-to-str 16 (str-to-int 64 (hash-keccak256 [(base64-encode arg)]))) +) + +(expect "keccak hash256 test vector: empty string" + "c5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470" + (hash-keccak "") +) + +(expect "keccak hash256 test vector: abc" + "4e03657aea45a94fc7d47ba826c8d667c0d1e6e33a64a036ec44f58fa12d6c45" + (hash-keccak "abc") +) + +(expect "keccak hash256 test vector: the quick brown fox" + "4d741b6f1eb29cb2a9b9911c82f56fa8d73b04959d3d9d222895df6c0b28aa15" + (hash-keccak "The quick brown fox jumps over the lazy dog") +) + +(commit-tx) diff --git a/pact-tests/pact-tests/marmalade/pact/marmalade.repl b/pact-tests/pact-tests/marmalade/pact/marmalade.repl index c35ce071..652e4203 100644 --- a/pact-tests/pact-tests/marmalade/pact/marmalade.repl +++ b/pact-tests/pact-tests/marmalade/pact/marmalade.repl @@ -435,3 +435,108 @@ (begin-tx "test utility functions") (commit-tx) + +(begin-tx) +(env-data { 'c-ks: {"keys": ["aaaaaaaaaaa"], "pred": "keys-all"}}) +; (env-module-admin coin) +; fund the account jose+robert some cash money +(test-capability (coin.CREDIT "jose+robert")) +(coin.credit "jose+robert" (read-keyset "c-ks") 1000000.0) + + +; This works in pact 5, but not pact 4 +; (with-capability (coin.CREDIT "jose+robert") +; (coin.credit "jose+robert" (read-keyset "c-ks") 1000000.0) +; ) + +(commit-tx) + +(begin-tx) +(namespace "marmalade-v2") + +(use marmalade-v2.ledger) +(use marmalade-v2.policy-manager) +(env-data { 'c-ks: {"keys": ["aaaaaaaaaaa"], "pred": "keys-all"}}) +(env-sigs [{"key":"aaaaaaaaaaa", "caps":[]}]) +(env-data + { 'c-ks: {"keys": ["aaaaaaaaaaa"], "pred": "keys-all"} + , "collection_id":"ayylmao" + , "royalty_spec": {"fungible":coin, "creator":"jose+robert", "creator-guard":(read-keyset "c-ks"), "royalty-rate":0.3} + }) + +(expect "Token ID matches" + "t:quzjryzeoVU6dk1fVVwxr8mmzvEtMIPBKitAagrSnSk" + (create-token-id { 'uri: "test1234565", 'precision: 0, 'policies: [non-fungible-policy-v1, royalty-policy-v1, guard-policy-v1] } (read-keyset "c-ks")) +) + +(commit-tx) + +; Setup module for collection id regressions +(begin-tx) +(env-exec-config ["DisablePact44"]) +(define-keyset "barbar" (read-keyset "c-ks")) +(module guard-gen g + (defcap g () true) + + (defcap FOO_CAP (a:integer b:string) true) + + (defun guard-foo (a:integer) (+ a 1)) + + (defun mk-user-guard:guard () + (create-user-guard (guard-foo 120)) + ) + + (defun mk-module-guard () + (create-module-guard "foobar") + ) + + (defun mk-keyset-ref-guard () + (keyset-ref-guard "barbar") + ) + + (defun mk-cap-guard () + (create-capability-guard (FOO_CAP 100 "200")) + ) + + ) +(env-exec-config []) + +(commit-tx) + +; Regressions for collection id +(begin-tx) +(namespace "marmalade-v2") +(use marmalade-v2.collection-policy-v1) +(expect + "collection id regression with keyset" + "collection:XM7DzU6oMzbl8KkOht8O7kTRT-BAE2KNBhf2wUWdQYw" + (create-collection-id "foo1" (read-keyset "c-ks")) + ) + +(expect + "collection id regression with user guard" + "collection:vHZAVuQ8gYgul9GROIV5AEvbDTe3Y-rG8LfEI-4V-i4" + (create-collection-id "foo2" (guard-gen.mk-user-guard)) + ) + +(expect + "collection id regression with module guard" + "collection:WA-PZx6TZDh0xdDqYW7agaGbp9i-EtTKca06rSDi4wg" + (create-collection-id "foo3" (guard-gen.mk-module-guard)) + ) + +(expect + "collection id regression with keyset-ref guard" + "collection:nBVmJkKNekDLdiBIL-wAhtrPt-2gMnHhsaPiQ-XtmiQ" + (create-collection-id "foo4" (guard-gen.mk-keyset-ref-guard)) + ) + +(expect + "collection id regression with cap guard" + "collection:HbkIz7-T8asUykS8146QQOPaVy_D8zI37CocIbjkdnU" + (create-collection-id "foo5" (guard-gen.mk-cap-guard)) + ) + + + +(commit-tx) diff --git a/pact-tests/pact-tests/poseidon-hash.repl b/pact-tests/pact-tests/poseidon-hash.repl index aeabeb01..bd44993b 100644 --- a/pact-tests/pact-tests/poseidon-hash.repl +++ b/pact-tests/pact-tests/poseidon-hash.repl @@ -8,3 +8,13 @@ (expect "1 2 3 4 5 6 should equal 20400040500897583745843009878988256314335038853985262692600694741116813247201" 20400040500897583745843009878988256314335038853985262692600694741116813247201 (poseidon-hash-hack-a-chain 1 2 3 4 5 6)) (expect "1 2 3 4 5 6 7 should equal 12748163991115452309045839028154629052133952896122405799815156419278439301912" 12748163991115452309045839028154629052133952896122405799815156419278439301912 (poseidon-hash-hack-a-chain 1 2 3 4 5 6 7)) (expect "1 2 3 4 5 6 7 8 should equal 18604317144381847857886385684060986177838410221561136253933256952257712543953" 18604317144381847857886385684060986177838410221561136253933256952257712543953 (poseidon-hash-hack-a-chain 1 2 3 4 5 6 7 8)) + +(expect "alias hash-poseidon 1 should equal 18586133768512220936620570745912940619677854269274689475585506675881198879027" 18586133768512220936620570745912940619677854269274689475585506675881198879027 (hash-poseidon 1)) +(expect "alias hash-poseidon 1 2 should equal 7853200120776062878684798364095072458815029376092732009249414926327459813530" 7853200120776062878684798364095072458815029376092732009249414926327459813530 (hash-poseidon 1 2)) +(expect "alias hash-poseidon 1 2 3 should equal 6542985608222806190361240322586112750744169038454362455181422643027100751666" 6542985608222806190361240322586112750744169038454362455181422643027100751666 (hash-poseidon 1 2 3)) +(expect "alias hash-poseidon 1 2 3 4 should equal 18821383157269793795438455681495246036402687001665670618754263018637548127333" 18821383157269793795438455681495246036402687001665670618754263018637548127333 (hash-poseidon 1 2 3 4)) +(expect "alias hash-poseidon 1 2 3 4 5 should equal 6183221330272524995739186171720101788151706631170188140075976616310159254464" 6183221330272524995739186171720101788151706631170188140075976616310159254464 (hash-poseidon 1 2 3 4 5)) +(expect "alias hash-poseidon 1 2 3 4 5 6 should equal 20400040500897583745843009878988256314335038853985262692600694741116813247201" 20400040500897583745843009878988256314335038853985262692600694741116813247201 (hash-poseidon 1 2 3 4 5 6)) +(expect "alias hash-poseidon 1 2 3 4 5 6 7 should equal 12748163991115452309045839028154629052133952896122405799815156419278439301912" 12748163991115452309045839028154629052133952896122405799815156419278439301912 (hash-poseidon 1 2 3 4 5 6 7)) +(expect "alias hash-poseidon 1 2 3 4 5 6 7 8 should equal 18604317144381847857886385684060986177838410221561136253933256952257712543953" 18604317144381847857886385684060986177838410221561136253933256952257712543953 (hash-poseidon 1 2 3 4 5 6 7 8)) + diff --git a/pact-tng.cabal b/pact-tng.cabal index 64b1d10b..391cd782 100644 --- a/pact-tng.cabal +++ b/pact-tng.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: pact-tng -version: 5.0 +version: 5.1 -- ^ 4 digit is prerelease, 3- or 2-digit for prod release synopsis: Smart contract language library and REPL description: @@ -138,9 +138,17 @@ library pact-crypto , semirings , deepseq , vector + , text + , base64-bytestring + , bytestring + , hashes >= 0.3 + , safe-exceptions + , deepseq exposed-modules: + Pact.Core.Crypto.Base64 Pact.Core.Crypto.Hash.Poseidon + Pact.Core.Crypto.Hash.Keccak256 Pact.Core.Crypto.Pairing Pact.Core.Crypto.Pairing.Fields if !(flag(with-crypto)) diff --git a/pact/Pact/Core/Builtin.hs b/pact/Pact/Core/Builtin.hs index 73bea94d..ff6bc810 100644 --- a/pact/Pact/Core/Builtin.hs +++ b/pact/Pact/Core/Builtin.hs @@ -239,6 +239,8 @@ data CoreBuiltin | CoreReadWithFields | CoreListModules | CoreStaticRedeploy + | CoreHashKeccak256 + | CoreHashPoseidon deriving (Eq, Show, Ord, Bounded, Enum, Generic) instance NFData CoreBuiltin @@ -413,6 +415,8 @@ coreBuiltinToText = \case CoreReadWithFields -> "read-with-fields" CoreListModules -> "list-modules" CoreStaticRedeploy -> "static-redeploy" + CoreHashKeccak256 -> "hash-keccak256" + CoreHashPoseidon -> "hash-poseidon" -- | Our `CoreBuiltin` user-facing representation. -- note: `coreBuiltinToUserText` is primarily for pretty printing @@ -565,6 +569,8 @@ coreBuiltinToUserText = \case CoreReadWithFields -> "read" CoreListModules -> "list-modules" CoreStaticRedeploy -> "static-redeploy" + CoreHashKeccak256 -> "hash-keccak256" + CoreHashPoseidon -> "hash-poseidon" instance IsBuiltin CoreBuiltin where builtinName = NativeName . coreBuiltinToText @@ -721,6 +727,8 @@ instance IsBuiltin CoreBuiltin where CoreReadWithFields -> 3 CoreListModules -> 0 CoreStaticRedeploy -> 1 + CoreHashKeccak256 -> 1 + CoreHashPoseidon -> 1 coreBuiltinNames :: [Text] coreBuiltinNames = diff --git a/pact/Pact/Core/Environment/Types.hs b/pact/Pact/Core/Environment/Types.hs index 4f147a65..063cdcbd 100644 --- a/pact/Pact/Core/Environment/Types.hs +++ b/pact/Pact/Core/Environment/Types.hs @@ -167,6 +167,8 @@ data ExecutionFlag | FlagDisableRuntimeRTC -- | Flag Enable legacy events | FlagEnableLegacyEventHashes + -- | Flag to disable features from pact 5.1 + | FlagDisablePact51 deriving (Eq,Ord,Show,Enum,Bounded, Generic) instance NFData ExecutionFlag diff --git a/pact/Pact/Core/Errors.hs b/pact/Pact/Core/Errors.hs index b994a714..3c1450b4 100644 --- a/pact/Pact/Core/Errors.hs +++ b/pact/Pact/Core/Errors.hs @@ -224,6 +224,7 @@ import Pact.Core.DeriveConTag import Pact.Core.ChainData (ChainId(_chainId)) import Data.String (IsString(..)) import Pact.Core.Gas.Types +import Pact.Core.Crypto.Hash.Keccak256 import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MP import Text.Read (readMaybe) @@ -720,6 +721,7 @@ data EvalError -- ^ Invalid number of arguments for a function | EntityNotAllowedInDefPact QualifiedName -- ^ Entity field not allowed in defpact + | Keccak256Error Keccak256Error deriving (Eq, Show, Generic) data ErrorClosureType @@ -936,6 +938,13 @@ instance Pretty EvalError where <+> parens (pretty expected) EntityNotAllowedInDefPact qn -> "Pact 5 does not support entity expressions in defpact" <+> pretty qn <> ". Please ensure your defpact steps have the correct number of expressions" + Keccak256Error err -> case err of + Keccak256OpenSslException msg -> + "OpenSSL error when keccak256 hashing:" <> pretty (T.pack msg) + Keccak256Base64Exception msg -> + "Base64URL decode failed:" <+> pretty (T.pack msg) + Keccak256OtherException msg -> + "Exception when keccak256 hashing:" <+> pretty (T.pack msg) -- | Errors meant to be raised -- internally by a PactDb implementation @@ -1629,6 +1638,17 @@ evalErrorToBoundedText = mkBoundedText . \case thsep [ "Pact 5 does not support entity expressions in defpact" , renderQualName qn <> "." , " Please ensure your defpact steps have the correct number of expressions"] + Keccak256Error err -> + thsep ["Keccak256 Hashing failure:", failure] + where + failure = case err of + Keccak256OpenSslException _msg -> + "OpenSSL error" + Keccak256Base64Exception _msg -> + "Base64URL decode failed" + Keccak256OtherException _ -> + "Unknown exception thrown during computation of keccak256" + -- | NOTE: Do _not_ change this function post mainnet release just to improve an error. diff --git a/pact/Pact/Core/Evaluate.hs b/pact/Pact/Core/Evaluate.hs index e7f6fcd3..f790fd63 100644 --- a/pact/Pact/Core/Evaluate.hs +++ b/pact/Pact/Core/Evaluate.hs @@ -26,6 +26,7 @@ module Pact.Core.Evaluate , evalInterpreter , EvalInput , EnableGasLogs(..) + , versionedNatives ) where import Control.Lens @@ -33,6 +34,7 @@ import Control.Monad import Control.Monad.Except import Control.Exception.Safe import Data.ByteString (ByteString) +import Data.Foldable(foldl') import Data.Maybe (fromMaybe) import Data.Default import Data.Map.Strict(Map) @@ -89,7 +91,7 @@ _decodeDbgModule fp = do putStrLn $ show $ pretty m putStrLn $ "\n\nPRETTY DEPS\n\n" () <$ traverse (putStrLn . show . pretty) (M.toList deps) - BS.writeFile (T.unpack (renderModuleName (_mName m))) $ _encodeModuleData serialisePact_lineinfo (def <$ (ModuleData m deps)) + BS.writeFile (T.unpack (renderModuleName (_mName m))) $ _encodeModuleData serialisePact_lineinfo_pact51 (def <$ (ModuleData m deps)) where unsafeAsModuleData = \case ModuleData m deps -> (m, deps) @@ -156,6 +158,17 @@ data EvalResult = EvalResult type Info = LineInfo +versionedNatives :: Set ExecutionFlag -> Map T.Text CoreBuiltin +versionedNatives ec = + disablePactNatives FlagDisablePact51 pact51Natives coreBuiltinMap + where + disablePactNatives flag natives = + if S.member flag ec then + flip (foldl' (\m' k -> M.delete (coreBuiltinToText k) m')) natives + else id + pact51Natives = [CoreHashPoseidon, CoreHashKeccak256] + + setupEvalEnv :: PactDb CoreBuiltin a -> ExecutionMode -- <- we have this @@ -178,7 +191,7 @@ setupEvalEnv pdb mode msgData mCont gasEnv np spv pd efs = do , _eeDefPactStep = contToPactStep <$> mCont , _eeMode = mode , _eeFlags = efs - , _eeNatives = coreBuiltinMap + , _eeNatives = versionedNatives efs , _eeNamespacePolicy = np , _eeGasEnv = gasEnv , _eeSPVSupport = spv diff --git a/pact/Pact/Core/Gas/TableGasModel.hs b/pact/Pact/Core/Gas/TableGasModel.hs index 6ea76564..6c1a5aac 100644 --- a/pact/Pact/Core/Gas/TableGasModel.hs +++ b/pact/Pact/Core/Gas/TableGasModel.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module Pact.Core.Gas.TableGasModel ( tableGasModel @@ -20,6 +21,7 @@ import qualified GHC.Integer.Logarithms as IntLog import Pact.Core.Builtin import Pact.Core.Gas.Types import Data.Decimal +import qualified Data.Vector as V import GHC.Base @@ -51,6 +53,8 @@ tableGasCostConfig = GasCostConfig , _gcDesugarBytePenalty = 400 , _gcMHashBytePenalty = 100 , _gcSizeOfBytePenalty = 5 + , _gc_keccak256GasPerOneHundredBytes = 146 + , _gc_keccak256GasPerChunk = 2_120 } @@ -383,8 +387,6 @@ runTableModel nativeTable GasCostConfig{..} = \case GSearch sty -> case sty of SubstringSearch needle hay -> MilliGas $ fromIntegral (T.length needle + T.length hay) + _gcNativeBasicWork FieldSearch cnt -> MilliGas $ fromIntegral cnt + _gcNativeBasicWork - GPoseidonHashHackAChain len -> - MilliGas $ fromIntegral (len * len) * _gcPoseidonQuadraticGasFactor + fromIntegral len * _gcPoseidonLinearGasFactor GModuleOp op -> case op of MOpLoadModule byteSize -> -- After some benchmarking, we can essentially say that the byte size of linear in @@ -455,14 +457,25 @@ runTableModel nativeTable GasCostConfig{..} = \case let !n = numberOfBits p !n_flt = (fromIntegral n :: Double) in fromIntegral n * ceiling ((log n_flt) ** 2) * ceiling (log (log n_flt)) - GHash w -> - MilliGas $ w * _gcMHashBytePenalty GCapOp op -> case op of CapOpRequire cnt -> let mgPerCap = 100 in MilliGas $ fromIntegral $ cnt * mgPerCap GHyperlaneMessageId m -> MilliGas $ fromIntegral m GHyperlaneEncodeDecodeTokenMessage m -> MilliGas $ fromIntegral m + GHashOp hashOp -> case hashOp of + GHashBlake w -> MilliGas $ w * _gcMHashBytePenalty + GHashPoseidon len -> + MilliGas $ fromIntegral (len * len) * _gcPoseidonQuadraticGasFactor + fromIntegral len * _gcPoseidonLinearGasFactor + GHashKeccak chunkBytes -> + let costPerOneHundredBytes = _gc_keccak256GasPerOneHundredBytes + costPerChunk = _gc_keccak256GasPerChunk + + -- we need to use ceiling here, otherwise someone could cheat by + -- having as many bytes as they want, but in chunks of 99 bytes. + gasOne numBytesInChunk = costPerChunk + costPerOneHundredBytes * ceiling (fromIntegral @_ @Double numBytesInChunk / 100.0) + + in MilliGas (V.sum (V.map gasOne chunkBytes)) where textCompareCost str = fromIntegral $ T.length str -- Running CountBytes costs 0.9 MilliGas, according to the analysis in bench/Bench.hs @@ -718,6 +731,8 @@ coreBuiltinGasCost GasCostConfig{..} = MilliGas . \case CoreReadWithFields -> _gcReadPenalty CoreListModules -> _gcMetadataTxPenalty CoreStaticRedeploy -> _gcNativeBasicWork + CoreHashKeccak256 -> 1_000 + CoreHashPoseidon -> 124_000 {-# INLINABLE runTableModel #-} diff --git a/pact/Pact/Core/Gas/Types.hs b/pact/Pact/Core/Gas/Types.hs index 304fbd3b..23d2e1b2 100644 --- a/pact/Pact/Core/Gas/Types.hs +++ b/pact/Pact/Core/Gas/Types.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE InstanceSigs #-} @@ -38,6 +39,7 @@ module Pact.Core.Gas.Types , StrOp(..) , ObjOp(..) , CapOp(..) + , HashOp(..) , ConcatType(..) , GasTextLength(..) , GasListLength(..) @@ -59,6 +61,7 @@ module Pact.Core.Gas.Types , TranscendentalCost(..) , EnableGasLogs(..) , module Pact.Core.SatWord + , pattern GHash ) where @@ -66,6 +69,7 @@ import Control.DeepSeq import Control.Lens import Data.Decimal(Decimal) import Data.Monoid +import Data.Vector(Vector) import Data.Primitive hiding (sizeOf) import qualified Data.Text as T import Data.Text (Text) @@ -169,6 +173,10 @@ data GasCostConfig -- ^ Module load hashing byte penalty , _gcSizeOfBytePenalty :: !SatWord -- ^ Our `SizeOf` limit penalty + , _gc_keccak256GasPerOneHundredBytes :: !SatWord + -- ^ Cost of keccak gas per 100 bytes + , _gc_keccak256GasPerChunk :: SatWord + -- ^ Cost of keccak gas per chunk } deriving (Eq, Show, Generic) instance NFData GasCostConfig @@ -272,7 +280,11 @@ data CapOp = CapOpRequire !Int deriving (Eq, Show, Ord, Generic, NFData) - +data HashOp + = GHashBlake !SatWord + | GHashPoseidon !Int + | GHashKeccak (Vector Int) + deriving (Eq, Show, Ord, Generic, NFData) data GasArgs b = GAConstant !MilliGas @@ -299,8 +311,6 @@ data GasArgs b -- ^ Gas costs for comparisons | GSearch !SearchType -- ^ Gas costs for searches - | GPoseidonHashHackAChain !Int - -- ^ poseidon-hash-hack-a-chain costs. | GHyperlaneMessageId !Int -- ^ ^ Cost of the hyperlane-message-id on this size (in bytes) of the -- hyperlane Message Body, which is the only variable-length @@ -315,7 +325,7 @@ data GasArgs b | GStrOp !StrOp | GObjOp !ObjOp | GCapOp !CapOp - | GHash !SatWord + | GHashOp !HashOp -- ^ The cost of Blake2b hashing a particular value in bytes deriving (Show, Eq, Generic, NFData) @@ -434,6 +444,11 @@ freeGasCostConfig = GasCostConfig , _gcDesugarBytePenalty = 1 -- ^ Module load desugaring byte penalty , _gcSizeOfBytePenalty = 1 + + , _gc_keccak256GasPerOneHundredBytes = 1 + -- ^ Cost of keccak gas per 100 bytes + , _gc_keccak256GasPerChunk = 1 + -- ^ Cost of keccak gas per chunk } data EnableGasLogs @@ -490,3 +505,6 @@ mkGasEnv enabled model = do mkFreeGasEnv :: EnableGasLogs -> IO (GasEnv b i) mkFreeGasEnv enabled = mkGasEnv enabled freeGasModel + +pattern GHash :: SatWord -> GasArgs b +pattern GHash w = GHashOp (GHashBlake w) diff --git a/pact/Pact/Core/Hash.hs b/pact/Pact/Core/Hash.hs index 86e5fc1f..2f48c600 100644 --- a/pact/Pact/Core/Hash.hs +++ b/pact/Pact/Core/Hash.hs @@ -42,11 +42,11 @@ import Data.Hashable (Hashable) import Data.Serialize (Serialize) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) -import Data.Word import GHC.Generics +import Pact.Core.Crypto.Base64 + import qualified Data.ByteString as B -import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Pact.JSON.Encode as J @@ -141,27 +141,6 @@ verifyHash h b = if hashed == h initialHash :: Hash initialHash = hash mempty -equalWord8 :: Word8 -equalWord8 = toEnum $ fromEnum '=' - -toB64UrlUnpaddedText :: ByteString -> Text -toB64UrlUnpaddedText = decodeUtf8 . encodeBase64UrlUnpadded - -encodeBase64UrlUnpadded :: ByteString -> ByteString -encodeBase64UrlUnpadded = fst . B.spanEnd (== equalWord8) . B64URL.encode - -decodeBase64UrlUnpadded :: ByteString -> Either String ByteString -decodeBase64UrlUnpadded = B64URL.decode . pad - where pad t = let s = B.length t `mod` 4 in t <> B.replicate ((4 - s) `mod` 4) equalWord8 - -fromB64UrlUnpaddedText :: ByteString -> Either String Text -fromB64UrlUnpaddedText bs = case decodeBase64UrlUnpadded bs of - Right bs' -> case T.decodeUtf8' bs' of - Left _ -> Left "Base64URL decode failed: invalid unicode" - Right t -> Right t - Left _ -> Left $ "Base64URL decode failed" - - newtype ModuleHash = ModuleHash { _mhHash :: Hash } deriving (Eq, Ord, Show, Generic) deriving newtype (Hashable, NFData, J.Encode, JD.FromJSON) diff --git a/pact/Pact/Core/IR/Desugar.hs b/pact/Pact/Core/IR/Desugar.hs index 8dd39bf2..edbe9d58 100644 --- a/pact/Pact/Core/IR/Desugar.hs +++ b/pact/Pact/Core/IR/Desugar.hs @@ -173,7 +173,9 @@ desugarCoreBuiltinArity f i CoreReadMsg [] = desugarCoreBuiltinArity f i CoreDefineKeySet [e1] = App (Builtin (f CoreDefineKeysetData) i) [e1] i desugarCoreBuiltinArity f i CorePoseidonHashHackachain li = - App (Builtin (f CorePoseidonHashHackachain) i )[(ListLit li i)] i + App (Builtin (f CorePoseidonHashHackachain) i) [(ListLit li i)] i +desugarCoreBuiltinArity f i CoreHashPoseidon li = + App (Builtin (f CoreHashPoseidon) i) [ListLit li i] i desugarCoreBuiltinArity f i CoreYield [e1, e2] = App (Builtin (f CoreYieldToChain) i) [e1, e2] i desugarCoreBuiltinArity f i CoreRead [e1, e2, e3] = diff --git a/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs b/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs index e5131113..d3a3037e 100644 --- a/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs +++ b/pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs @@ -71,6 +71,7 @@ import Pact.Core.Info #ifndef WITHOUT_CRYPTO import Pact.Core.Crypto.Pairing import Pact.Core.Crypto.Hash.Poseidon +import Pact.Core.Crypto.Hash.Keccak256 #endif import Pact.Crypto.Hyperlane @@ -1898,10 +1899,22 @@ poseidonHash info b cont handler _env = \case [VList as] | not (V.null as) && length as <= 8, Just intArgs <- traverse (preview (_PLiteral . _LInteger)) as -> do - chargeGasArgs info (GPoseidonHashHackAChain (length intArgs)) + chargeGasArgs info (GHashOp (GHashPoseidon (length intArgs))) returnCEKValue cont handler $ VInteger (poseidon (V.toList intArgs)) args -> argsError info b args +coreHashKeccak256 :: (IsBuiltin b) => NativeFunction e b i +coreHashKeccak256 info b cont handler _env = \case + [VList li] -> do + texts <- traverse (asString info b) li + let chunkBytes = V.map (BS.length . T.encodeUtf8) texts + chargeGasArgs info (GHashOp (GHashKeccak chunkBytes)) + output <- case keccak256 texts of + Left keccakErr -> throwExecutionError info (Keccak256Error keccakErr) + Right output -> pure output + returnCEKValue cont handler (VString output) + args -> argsError info b args + #else zkPairingCheck :: NativeFunction e b i @@ -1916,6 +1929,9 @@ zkPointAddition info _b _cont _handler _env _args = throwExecutionError info $ E poseidonHash :: NativeFunction e b i poseidonHash info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" +coreHashKeccak256 :: NativeFunction e b i +coreHashKeccak256 info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" + #endif ----------------------------------- @@ -2032,6 +2048,9 @@ coreStaticRedeploy info b cont handler env = \case ModuleData m _ -> _mCode m InterfaceData iface _ -> _ifCode iface + + + ----------------------------------- -- Builtin exports ----------------------------------- @@ -2194,3 +2213,5 @@ coreBuiltinRuntime = \case CoreReadWithFields -> dbRead CoreListModules -> coreListModules CoreStaticRedeploy -> coreStaticRedeploy + CoreHashPoseidon -> poseidonHash + CoreHashKeccak256 -> coreHashKeccak256 diff --git a/pact/Pact/Core/Serialise.hs b/pact/Pact/Core/Serialise.hs index 5aa5384b..8c7965ee 100644 --- a/pact/Pact/Core/Serialise.hs +++ b/pact/Pact/Core/Serialise.hs @@ -16,7 +16,8 @@ module Pact.Core.Serialise , document , serialisePact , serialisePact_raw_spaninfo - , serialisePact_lineinfo + , serialisePact_lineinfo_pact50 + , serialisePact_lineinfo_pact51 , serialisePact_repl_spaninfo , serialisePact_repl_fileLocSpanInfo , decodeVersion @@ -102,7 +103,7 @@ serialisePact :: PactSerialise CoreBuiltin () serialisePact = PactSerialise { _encodeModuleData = docEncode V1.encodeModuleData , _decodeModuleData = \bs -> - LegacyDocument <$> LegacyPact.decodeModuleData bs + LegacyDocument <$> LegacyPact.decodeModuleData LegacyPact.LegacyKeccakPatchDisabled bs <|> docDecode bs (\case V1_CBOR -> V1.decodeModuleData ) @@ -160,7 +161,7 @@ serialisePact_repl_spaninfo = serialisePact { _encodeModuleData = docEncode V1.encodeModuleData_repl_spaninfo , _decodeModuleData = \bs -> - (LegacyDocument . fmap (\_ -> def) . liftReplBuiltin <$> LegacyPact.decodeModuleData bs) + (LegacyDocument . fmap (\_ -> def) . liftReplBuiltin <$> LegacyPact.decodeModuleData LegacyPact.LegacyKeccakPatchDisabled bs) <|> docDecode bs (\case V1_CBOR -> V1.decodeModuleData_repl_spaninfo ) @@ -172,7 +173,7 @@ serialisePact_repl_fileLocSpanInfo = serialisePact { _encodeModuleData = docEncode V1.encodeModuleData_repl_flspaninfo , _decodeModuleData = \bs -> - (LegacyDocument . fmap (\_ -> def) . liftReplBuiltin <$> LegacyPact.decodeModuleData bs) + (LegacyDocument . fmap (\_ -> def) . liftReplBuiltin <$> LegacyPact.decodeModuleData LegacyPact.LegacyKeccakPatchDisabled bs) <|> docDecode bs (\case V1_CBOR -> V1.decodeModuleData_repl_flspaninfo ) @@ -194,19 +195,31 @@ serialisePact_raw_spaninfo = serialisePact { _encodeModuleData = docEncode V1.encodeModuleData_raw_spaninfo , _decodeModuleData = \bs -> - (LegacyDocument . fmap (\_ -> def) <$> LegacyPact.decodeModuleData bs) + (LegacyDocument . fmap (\_ -> def) <$> LegacyPact.decodeModuleData LegacyPact.LegacyKeccakPatchDisabled bs) <|> docDecode bs (\case V1_CBOR -> V1.decodeModuleData_raw_spaninfo ) , _encodeRowData = gEncodeRowData } -serialisePact_lineinfo :: PactSerialise CoreBuiltin LineInfo -serialisePact_lineinfo = serialisePact +serialisePact_lineinfo_pact51 :: PactSerialise CoreBuiltin LineInfo +serialisePact_lineinfo_pact51 = serialisePact { _encodeModuleData = docEncode V1.encodeModuleData_lineinfo , _decodeModuleData = \bs -> - (LegacyDocument . fmap (\_ -> def) <$> LegacyPact.decodeModuleData bs) + (LegacyDocument . fmap (\_ -> def) <$> LegacyPact.decodeModuleData LegacyPact.LegacyKeccakPatchDisabled bs) + <|> docDecode bs (\case + V1_CBOR -> V1.decodeModuleData_lineinfo + ) + , _encodeRowData = gEncodeRowData + } + +serialisePact_lineinfo_pact50 :: PactSerialise CoreBuiltin LineInfo +serialisePact_lineinfo_pact50 = serialisePact + { _encodeModuleData = docEncode V1.encodeModuleData_lineinfo + , _decodeModuleData = + \bs -> + (LegacyDocument . fmap (\_ -> def) <$> LegacyPact.decodeModuleData LegacyPact.LegacyKeccakPatchEnabled bs) <|> docDecode bs (\case V1_CBOR -> V1.decodeModuleData_lineinfo ) diff --git a/pact/Pact/Core/Serialise/LegacyPact.hs b/pact/Pact/Core/Serialise/LegacyPact.hs index fc8a054b..02279618 100644 --- a/pact/Pact/Core/Serialise/LegacyPact.hs +++ b/pact/Pact/Core/Serialise/LegacyPact.hs @@ -20,6 +20,7 @@ module Pact.Core.Serialise.LegacyPact , fromLegacyNamespace , fromLegacyDefPactExec , runTranslateM + , IsLegacyPactKeccakPatchEnabled(..) ) where import Control.Lens @@ -84,10 +85,15 @@ data TranslateState = makeLenses ''TranslateState +data IsLegacyPactKeccakPatchEnabled + = LegacyKeccakPatchEnabled + | LegacyKeccakPatchDisabled + deriving (Show, Eq) -newtype TranslateEnv +data TranslateEnv = TranslateEnv { _teDepth :: DeBruijn + , _tePact5KeccakHashPatchEnabled :: IsLegacyPactKeccakPatchEnabled } deriving (Show, Eq) makeLenses ''TranslateEnv @@ -97,23 +103,30 @@ type TranslateM = ReaderT TranslateEnv (StateT TranslateState (Except String)) pattern UnitVal :: Term name ty builtin info pattern UnitVal <- InlineValue (PLiteral LUnit) _ -runTranslateM :: TranslateM a -> Either String a -runTranslateM a = - let initialEnv = TranslateEnv 0 +runTranslateM :: IsLegacyPactKeccakPatchEnabled -> TranslateM a -> Either String a +runTranslateM pact51Enabled a = + let initialEnv = TranslateEnv 0 pact51Enabled initialState = TranslateState mempty mempty in runExcept (evalStateT (runReaderT a initialEnv) initialState) -decodeModuleData :: ByteString -> Maybe (ModuleData CoreBuiltin ()) -decodeModuleData bs = do +decodeModuleData :: IsLegacyPactKeccakPatchEnabled -> ByteString -> Maybe (ModuleData CoreBuiltin ()) +decodeModuleData b bs = do obj <- JD.decodeStrict' bs - case runTranslateM (fromLegacyModuleData obj) of + case runTranslateM b (fromLegacyModuleData obj) of Left _ -> Nothing Right v -> Just v decodeModuleData' :: ByteString -> Either String (ModuleData CoreBuiltin ()) decodeModuleData' bs = do obj <- maybe (Left "decodingError") Right $ JD.decodeStrict' bs - runTranslateM (fromLegacyModuleData obj) + runTranslateM LegacyKeccakPatchDisabled (fromLegacyModuleData obj) + +isLegacyKeccakPatchEnabled :: TranslateM Bool +isLegacyKeccakPatchEnabled = views tePact5KeccakHashPatchEnabled (== LegacyKeccakPatchEnabled) + +legacyKeccakPatchNatives :: S.Set T.Text +legacyKeccakPatchNatives = + S.fromList $ coreBuiltinToText <$> [CoreHashPoseidon, CoreHashKeccak256] fromLegacyModuleData :: Legacy.ModuleData (Legacy.Ref' Legacy.PersistDirect) @@ -564,13 +577,19 @@ fromLegacyPersistDirect = \case d <- view teDepth pure $ Lam (c1 :| [c2]) (Var (Name "#constantlyA1" (NBound 1), d+2) ()) () - | otherwise -> case M.lookup n coreBuiltinMap of + | otherwise -> do + builtins <- getPatchedLookupMap + case M.lookup n builtins of Just b -> pure (Builtin b ()) _ -> throwError $ "fromLegacyPersistDirect: invariant -> " <> show n Legacy.PDFreeVar fqn -> let fqn' = fromLegacyFullyQualifiedName fqn in pure $ Var (fqnToName fqn', 0) () where + getPatchedLookupMap = do + isPatchEnabled <- isLegacyKeccakPatchEnabled + if isPatchEnabled then pure $ M.withoutKeys coreBuiltinMap legacyKeccakPatchNatives + else pure coreBuiltinMap -- Note: unit* is used as placeholder, which gets replaced in `fromLegacyTerm` unitValue = InlineValue PUnit () diff --git a/profile-tx/ProfileTx.hs b/profile-tx/ProfileTx.hs index 4aaa522f..2c662145 100644 --- a/profile-tx/ProfileTx.hs +++ b/profile-tx/ProfileTx.hs @@ -188,7 +188,7 @@ setupCoinTxs pdb = do _run :: IO () _run = do - pdb <- mockPactDb serialisePact_lineinfo + pdb <- mockPactDb serialisePact_lineinfo_pact51 setupCoinTxs pdb >>= print coinTransferTxRaw :: Text -> Text -> Text @@ -229,7 +229,7 @@ transferSigners sender receiver = M.singleton (pubKeyFromSender sender) (S.singleton (transferCapFromSender sender receiver 200.0)) _testCoinTransfer :: IO () -_testCoinTransfer = withSqlitePactDb serialisePact_lineinfo (T.pack benchmarkSqliteFile) $ \pdb -> do +_testCoinTransfer = withSqlitePactDb serialisePact_lineinfo_pact51 (T.pack benchmarkSqliteFile) $ \pdb -> do _ <- ignoreGas def $ _pdbBeginTx pdb Transactional p <- setupCoinTxs pdb print p @@ -280,7 +280,7 @@ mkCoinIdent :: Text -> Name mkCoinIdent n = Name n (NTopLevel (ModuleName "coin" Nothing) (ModuleHash {_mhHash = unsafeModuleHash "DFsR46Z3vJzwyd68i0MuxIF0JxZ_OJfIaMyFFgAyI4w"})) main :: IO () -main = withSqlitePactDb serialisePact_lineinfo (T.pack benchmarkSqliteFile) $ \pdb -> do +main = withSqlitePactDb serialisePact_lineinfo_pact51 (T.pack benchmarkSqliteFile) $ \pdb -> do withTx pdb $ setupCoinTxs pdb withTx pdb $ prePopulateCoinEntries pdb runCoinXferDirect pdb diff --git a/test-utils/Pact/Core/PactDbRegression.hs b/test-utils/Pact/Core/PactDbRegression.hs index 12001b5b..a55c112e 100644 --- a/test-utils/Pact/Core/PactDbRegression.hs +++ b/test-utils/Pact/Core/PactDbRegression.hs @@ -41,7 +41,7 @@ runPactDbRegression pdb = do Just t -> pure t let row = RowData $ M.fromList [(Field "gah", PDecimal 123.454345)] - rowEnc <- ignoreGas def $ _encodeRowData serialisePact_lineinfo row + rowEnc <- ignoreGas def $ _encodeRowData serialisePact_lineinfo_pact51 row ignoreGas def $ _pdbWrite pdb Insert (DUserTables usert) (RowKey "key1") row row' <- do ignoreGas def (_pdbRead pdb (DUserTables usert) (RowKey "key1")) >>= \case @@ -54,7 +54,7 @@ runPactDbRegression pdb = do [ (Field "gah", PBool False) , (Field "fh", PInteger 1) ] - row2Enc <- ignoreGas def $ _encodeRowData serialisePact_lineinfo row2 + row2Enc <- ignoreGas def $ _encodeRowData serialisePact_lineinfo_pact51 row2 ignoreGas def $ _pdbWrite pdb Update (DUserTables usert) (RowKey "key1") row2 row2' <- ignoreGas def $ _pdbRead pdb (DUserTables usert) (RowKey "key1") >>= \case @@ -64,7 +64,7 @@ runPactDbRegression pdb = do let ks = KeySet (S.fromList [PublicKeyText "skdjhfskj"]) KeysAll - ksEnc = _encodeKeySet serialisePact_lineinfo ks + ksEnc = _encodeKeySet serialisePact_lineinfo_pact51 ks _ <- ignoreGas def $ _pdbWrite pdb Write DKeySets (KeySetName "ks1" Nothing) ks ks' <- ignoreGas def $ _pdbRead pdb DKeySets (KeySetName "ks1" Nothing) >>= \case Nothing -> error "expected keyset" @@ -75,7 +75,7 @@ runPactDbRegression pdb = do -- module let mn = ModuleName "test" Nothing md <- loadModule - let mdEnc = _encodeModuleData serialisePact_lineinfo md + let mdEnc = _encodeModuleData serialisePact_lineinfo_pact51 md ignoreGas def $ _pdbWrite pdb Write DModules mn md md' <- ignoreGas def $ _pdbRead pdb DModules mn >>= \case @@ -121,7 +121,7 @@ runPactDbRegression pdb = do loadModule :: IO (ModuleData CoreBuiltin Info) loadModule = do let src = RawCode "(module test G (defcap G () true) (defun f (a: integer) 1))" - pdb <- mockPactDb serialisePact_lineinfo + pdb <- mockPactDb serialisePact_lineinfo_pact51 ee <- defaultEvalEnv pdb coreBuiltinMap Right _ <- runEvalMResult (ExecEnv ee) def $ do p <- liftEither (compileOnlyLineInfo src)