Add keccak256 and hash-poseidon, bump pact version to pact 5, add tests

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

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

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

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

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)
 

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

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)

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

pact-tests/Pact/Core/Test/PersistenceTests.hs

@@ -112,12 +112,12 @@ 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"
     (runPactDbRegression =<< fmap (view _1) db)
 
 pureDbRegression :: TestTree
 pureDbRegression = testCase "PureDb regression"
-  (runPactDbRegression =<< mockPactDb serialisePact_lineinfo)
+  (runPactDbRegression =<< mockPactDb serialisePact_lineinfo_pact51)

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"}
 

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"}
 

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)