diff --git a/bench/Chainweb/Pact/Backend/PactService.hs b/bench/Chainweb/Pact/Backend/PactService.hs index 6818e5d1bc..9bf9c832d0 100644 --- a/bench/Chainweb/Pact/Backend/PactService.hs +++ b/bench/Chainweb/Pact/Backend/PactService.hs @@ -82,17 +82,17 @@ bench :: RocksDb -> C.Benchmark bench rdb = do C.bgroup "PactService" [ C.bgroup "Pact4" - [ C.bench "1 tx" $ oneBlock pact4Version rdb 1 - , C.bench "10 txs" $ oneBlock pact4Version rdb 10 - , C.bench "20 txs" $ oneBlock pact4Version rdb 20 - , C.bench "30 txs" $ oneBlock pact4Version rdb 30 - , C.bench "40 txs" $ oneBlock pact4Version rdb 40 - , C.bench "50 txs" $ oneBlock pact4Version rdb 50 - , C.bench "60 txs" $ oneBlock pact4Version rdb 60 - , C.bench "70 txs" $ oneBlock pact4Version rdb 70 - , C.bench "80 txs" $ oneBlock pact4Version rdb 80 - , C.bench "90 txs" $ oneBlock pact4Version rdb 90 - , C.bench "100 txs" $ oneBlock pact4Version rdb 100 + [ C.bench "1 tx" $ oneBlockV4 pact4Version rdb 1 + , C.bench "10 txs" $ oneBlockV4 pact4Version rdb 10 + , C.bench "20 txs" $ oneBlockV4 pact4Version rdb 20 + , C.bench "30 txs" $ oneBlockV4 pact4Version rdb 30 + , C.bench "40 txs" $ oneBlockV4 pact4Version rdb 40 + , C.bench "50 txs" $ oneBlockV4 pact4Version rdb 50 + , C.bench "60 txs" $ oneBlockV4 pact4Version rdb 60 + , C.bench "70 txs" $ oneBlockV4 pact4Version rdb 70 + , C.bench "80 txs" $ oneBlockV4 pact4Version rdb 80 + , C.bench "90 txs" $ oneBlockV4 pact4Version rdb 90 + , C.bench "100 txs" $ oneBlockV4 pact4Version rdb 100 ] , C.bgroup "Pact5" [ C.bench "1 tx" $ oneBlock pact5Version rdb 1 @@ -163,6 +163,36 @@ destroyFixture fx = do closeSQLiteConnection sql deleteNamespaceRocksDb fx._fixtureBlockDbRocksDb + +oneBlockV4 :: ChainwebVersion -> RocksDb -> Word -> C.Benchmarkable +oneBlockV4 v rdb numTxs = + let cid = unsafeChainId 0 + cfg = testPactServiceConfig + + setupEnv _ = do + fx <- createFixture v rdb cfg + txs <- forM [1..numTxs] $ \_ -> do + buildCwCmdNoParse v (transferCmd cid 1.0) + return (fx, txs) + + cleanupEnv _ (fx, _) = do + destroyFixture fx + in + C.perBatchEnvWithCleanup setupEnv cleanupEnv $ \ ~(fx, txs) -> do + prevCut <- getCut fx + result <- advanceAllChains fx $ onChain cid $ \ph pactQueue mempool -> do + mempoolClear mempool + mempoolInsert (fx._fixtureMempools ^?! atChain cid) UncheckedInsert $ Vector.fromList txs + + bip <- throwIfNoHistory =<< + newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue + let block = forAnyPactVersion finalizeBlock bip + fromIntegral @_ @Word (Vector.length (_payloadWithOutputsTransactions block)) + & P.equals numTxs + return block + revert fx prevCut + return result + oneBlock :: ChainwebVersion -> RocksDb -> Word -> C.Benchmarkable oneBlock v rdb numTxs = let cid = unsafeChainId 0 diff --git a/cabal.project b/cabal.project index 9ea31d9dfa..dc73952dd4 100644 --- a/cabal.project +++ b/cabal.project @@ -101,8 +101,7 @@ source-repository-package source-repository-package type: git location: https://github.com/kda-community/pact-5.git - tag: bfc5310c462aaefabe7c512407ac6dab87fc8c42 - --sha256: 05xp1vwxkvjxrn8pij9z4g1hadbkb8hrgziwzs408yxxxmkcv6kq + tag: cbf0f14286f9ffa3d86c0bee08e121b4e679459e source-repository-package type: git diff --git a/src/Chainweb/Miner/Coordinator.hs b/src/Chainweb/Miner/Coordinator.hs index a5a2fc210d..e4bc18affc 100644 --- a/src/Chainweb/Miner/Coordinator.hs +++ b/src/Chainweb/Miner/Coordinator.hs @@ -238,7 +238,7 @@ newWork logFun choice targetFork eminer@(Miner mid _) hdb pact tpw c = do logFun @T.Text Debug $ "newWork: chain " <> toText cid <> " not mineable" newWork logFun Anything targetFork eminer hdb pact tpw c Just (T2 (WorkReady newBlock) extension) -> do - let (primedParentHash, primedParentHeight, _) = newBlockParent newBlock + let (primedParentHash, _, primedParentHeight, _) = newBlockParent newBlock if primedParentHash == view blockHash (_parentHeader (_cutExtensionParent extension)) then do let payload = newBlockToPayloadWithOutputs newBlock diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 0852ac0c3f..08863a300e 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -115,6 +115,7 @@ import qualified Chainweb.Pact4.Transaction as Pact4 import Chainweb.TreeDB import Chainweb.Utils hiding (check) import Chainweb.Version +import Chainweb.ForkState (pact4ForkNumber) import Chainweb.Version.Guards import Utils.Logging.Trace import Chainweb.Counter @@ -818,7 +819,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do Left err -> earlyReturn $ review _MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err Right _ -> return () _ -> do - let validated = Pact4.assertCommand pact4Cwtx (validPPKSchemes v cid bh) (isWebAuthnPrefixLegal v cid bh) + let validated = Pact4.assertCommand pact4Cwtx (validPPKSchemes v cid pact4ForkNumber bh) (isWebAuthnPrefixLegal v cid bh) case validated of Left err -> earlyReturn $ review _MetadataValidationFailure (pure $ displayAssertCommandError err) Right () -> return () @@ -860,7 +861,12 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do let localPact5 = do ph <- view psParentHeader - let pact5RequestKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx) + let txCtx = Pact5.TxContext ph noMiner + bh = Pact5.ctxCurrentBlockHeight txCtx + fn = Pact5.ctxParentForkNumber txCtx + pact5RequestKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx) + spvSupport = Pact5.pactSPV bhdb (_parentHeader ph) + evalContT $ withEarlyReturn $ \earlyReturn -> do pact5Cmd <- case Pact5.parsePact4Command cwtx of Left (Left errText) -> do @@ -903,14 +909,12 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do review _MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err Right _ -> return () _ -> do - let validated = Pact5.assertCommand pact5Cmd + let validated = Pact5.assertCommand pact5Cmd (validPPKSchemes v cid fn bh) case validated of Left err -> earlyReturn $ review _MetadataValidationFailure (pure $ displayAssertCommandError err) Right () -> return () - let txCtx = Pact5.TxContext ph noMiner - let spvSupport = Pact5.pactSPV bhdb (_parentHeader ph) case preflight of Just PreflightSimulation -> do -- preflight needs to do additional checks on the metadata @@ -1181,13 +1185,14 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do let parentTime = ParentCreationTime (view blockCreationTime $ _parentHeader ph) currHeight = succ $ view blockHeight $ _parentHeader ph + parentForkNumber = view blockForkNumber $ _parentHeader ph isGenesis = False forM txs $ \tx -> fmap (either Just (\_ -> Nothing)) $ runExceptT $ do -- it's safe to use initialBlockHandle here because it's -- only used to check for duplicate pending txs in a block pact5Tx <- mapExceptT liftIO $ Pact5.validateRawChainwebTx - logger v cid db initialBlockHandle parentTime currHeight isGenesis tx + logger v cid db initialBlockHandle parentTime parentForkNumber currHeight isGenesis tx let logger' = addLabel ("transaction", "attemptBuyGas") logger ExceptT $ Pact5.pactTransaction Nothing $ \pactDb -> runExceptT $ do let txCtx = Pact5.TxContext ph noMiner diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index a0fb97a8c1..7937506f04 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -337,7 +337,7 @@ checkTxSigs logger v cid bh t = do hsh = Pact4._cmdHash t sigs = Pact4._cmdSigs t signers = Pact4._pSigners $ Pact4.payloadObj $ Pact4._cmdPayload t - validSchemes = validPPKSchemes v cid bh + validSchemes = validPPKSchemes v cid pact4ForkNumber bh webAuthnPrefixLegal = isWebAuthnPrefixLegal v cid bh checkCompile diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 44f5bc2b50..ff59433164 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -36,6 +36,7 @@ import Chainweb.Pact5.Transaction import Chainweb.Pact5.TransactionExec import Chainweb.Pact5.Types import Chainweb.Payload +import Chainweb.ForkState import Chainweb.Payload.PayloadStore import Chainweb.Time import Chainweb.Utils @@ -328,11 +329,11 @@ continueBlock mpAccess blockInProgress = do cid <- view chainId logger <- view (psServiceEnv . psLogger) dbEnv <- view psBlockDbEnv - let (pHash, pHeight, parentTime) = blockInProgressParent blockInProgress + let (pHash, pForkNumber, pHeight, parentTime) = blockInProgressParent blockInProgress isGenesis <- view psIsGenesis let validate bhi _bha txs = do forM txs $ - runExceptT . validateRawChainwebTx logger v cid dbEnv (_blockInProgressHandle blockInProgress) (ParentCreationTime parentTime) bhi isGenesis + runExceptT . validateRawChainwebTx logger v cid dbEnv (_blockInProgressHandle blockInProgress) (ParentCreationTime parentTime) pForkNumber bhi isGenesis liftIO $ mpaGetBlock mpAccess blockFillState validate (succ pHeight) pHash @@ -477,13 +478,15 @@ validateParsedChainwebTx -> BlockHandle Pact5 -> ParentCreationTime -- ^ reference time for tx validation. + -> ForkNumber + -- ^ Parent Fork number -> BlockHeight -- ^ Current block height -> Bool -- ^ Genesis? -> Pact5.Transaction -> ExceptT InsertError IO () -validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime bh isGenesis tx +validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime fn bh isGenesis tx | isGenesis = pure () | otherwise = do checkUnique tx @@ -531,7 +534,7 @@ validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime bh isGen checkTxSigs :: Pact5.Transaction -> ExceptT InsertError IO () checkTxSigs t = do - case Pact5.assertValidateSigs hsh signers sigs of + case Pact5.assertValidateSigs (validPPKSchemes v cid fn bh) hsh signers sigs of Right _ -> do pure () Left err -> do @@ -558,17 +561,19 @@ validateRawChainwebTx -> BlockHandle Pact5 -> ParentCreationTime -- ^ reference time for tx validation. + -> ForkNumber + -- ^ Parent Fork number -> BlockHeight -- ^ Current block height -> Bool -- ^ Genesis? -> Pact4.UnparsedTransaction -> ExceptT InsertError IO Pact5.Transaction -validateRawChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx = do +validateRawChainwebTx logger v cid db blockHandle parentTime fn bh isGenesis tx = do tx' <- either (throwError . InsertErrorPactParseError . either id Pact5.renderText) return $ Pact5.parsePact4Command tx liftIO $ do logDebug_ logger $ "validateRawChainwebTx: parse succeeded" - validateParsedChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx' + validateParsedChainwebTx logger v cid db blockHandle parentTime fn bh isGenesis tx' return $! tx' execExistingBlock @@ -594,7 +599,8 @@ execExistingBlock currHeader payload = do errors <- liftIO $ flip foldMap txs $ \tx -> do errorOrSuccess <- runExceptT $ validateParsedChainwebTx logger v cid db blockHandlePreCoinbase txValidationTime - (view blockHeight currHeader) + (parentBlockHeader ^. blockForkNumber) + (currHeader ^. blockHeight) isGenesis tx case errorOrSuccess of diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index 80f7ea94ea..992c44995d 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -91,6 +91,7 @@ import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.BlockHeight +import Chainweb.ForkState import Chainweb.ChainId import Chainweb.Crypto.MerkleLog import Chainweb.Cut @@ -106,6 +107,7 @@ import Chainweb.Pact.Types import Chainweb.Pact4.SPV qualified as Pact4 import Pact.Types.ChainMeta qualified as Pact4 import Chainweb.Payload +import Chainweb.Version.Guards (getForkHeight) import Chainweb.Payload.PayloadStore import Chainweb.RestAPI.Orphans () import Chainweb.RestAPI.Utils @@ -718,12 +720,17 @@ barf e = maybe (throwError e) return validateCommand :: ChainwebVersion -> ChainId -> Pact4.Command Text -> Either Text Pact4.Transaction validateCommand v cid (fmap encodeUtf8 -> cmdBs) = case parsedCmd of Right (commandParsed :: Pact4.Transaction) -> - case Pact4.assertCommand commandParsed (validPPKSchemes v cid bh) (isWebAuthnPrefixLegal v cid bh) of + case Pact4.assertCommand commandParsed (validPPKSchemes v cid pact4ForkNumber bh) (isWebAuthnPrefixLegal v cid bh) of Left err -> Left $ "Command failed validation: " <> Pact4.displayAssertCommandError err Right () -> Right commandParsed Left e -> Left $ "Pact parsing error: " <> T.pack e where - bh = maxBound :: BlockHeight + -- It's supposed to be a Pact4 command, so take the height just before the Pact5 fork + bh = case getForkHeight Pact5Fork v cid of + ForkAtGenesis -> minBound :: BlockHeight + ForkAtBlockHeight bh' -> bh' -1 + _ -> maxBound :: BlockHeight + decodeAndParse bs = traverse (Pact4.parsePact) =<< Aeson.eitherDecodeStrict' bs parsedCmd = Pact4.mkPayloadWithText <$> @@ -731,15 +738,19 @@ validateCommand v cid (fmap encodeUtf8 -> cmdBs) = case parsedCmd of -- TODO: all of the functions in this module can instead grab the current block height from consensus -- and pass it here to get a better estimate of what behavior is correct. -validatePact5Command :: ChainwebVersion -> Pact5.Command Text -> Either String Pact5.Transaction -validatePact5Command _v cmdText = case parsedCmd of +validatePact5Command :: ChainwebVersion -> ChainId -> Pact5.Command Text -> Either String Pact5.Transaction +validatePact5Command _v cid cmdText = case parsedCmd of Right (commandParsed :: Pact5.Transaction) -> - if isRight (Pact5.assertCommand commandParsed) + if isRight $ Pact5.assertCommand commandParsed $ validPPKSchemes _v cid fn bh then Right commandParsed else Left "Command failed validation" Left e -> Left $ "Pact parsing error: " ++ Pact5.renderCompactString e where parsedCmd = Pact5.parseCommand cmdText + -- For Pact5, we take the highest possible BlockHeight and ForkNumber + bh = maxBound :: BlockHeight + fn = maxBound :: ForkNumber + -- | Validate the length of the request key's underlying hash. -- diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index c7c4d4e589..f0489857fc 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -227,6 +227,7 @@ import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.BlockHeaderDB import Chainweb.ChainId +import Chainweb.ForkState import Chainweb.Counter import Chainweb.Mempool.Mempool (TransactionHash, BlockFill, MempoolPreBlockCheck, InsertError) import Chainweb.Miner.Pact @@ -1189,11 +1190,11 @@ instance HasChainId (BlockInProgress pv) where _chainId = _blockInProgressChainId {-# INLINE _chainId #-} -blockInProgressParent :: BlockInProgress pv -> (BlockHash, BlockHeight, BlockCreationTime) +blockInProgressParent :: BlockInProgress pv -> (BlockHash, ForkNumber, BlockHeight, BlockCreationTime) blockInProgressParent bip = maybe - (genesisParentBlockHash v cid, genesisHeight v cid, v ^?! versionGenesis . genesisTime . atChain cid) - (\bh -> (view blockHash bh, view blockHeight bh, view blockCreationTime bh)) + (genesisParentBlockHash v cid, genesisForkState ^. forkNumber, genesisHeight v cid, v ^?! versionGenesis . genesisTime . atChain cid) + (\bh -> (view blockHash bh, view blockForkNumber bh, view blockHeight bh, view blockCreationTime bh)) (_parentHeader <$> _blockInProgressParentHeader bip) where v = _blockInProgressChainwebVersion bip diff --git a/src/Chainweb/Pact4/Validations.hs b/src/Chainweb/Pact4/Validations.hs index d279ec439e..e3c61035d8 100644 --- a/src/Chainweb/Pact4/Validations.hs +++ b/src/Chainweb/Pact4/Validations.hs @@ -57,13 +57,14 @@ import Data.Word (Word8) -- internal modules import Chainweb.BlockHeader +import Chainweb.ForkState (pact4ForkNumber) import Chainweb.BlockCreationTime (BlockCreationTime(..)) import Chainweb.Pact.Types import Chainweb.Pact.Utils (fromPactChainId) import Chainweb.Time (Seconds(..), Time(..), secondsToTimeSpan, scaleTimeSpan, second, add) import Chainweb.Pact4.Transaction import Chainweb.Version -import Chainweb.Version.Guards (isWebAuthnPrefixLegal, validPPKSchemes) +import Chainweb.Version.Guards (PactPPKScheme(..), isWebAuthnPrefixLegal, validPPKSchemes) import qualified Pact.Types.Gas as P import qualified Pact.Types.Hash as P @@ -89,7 +90,7 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do bgl <- view psBlockGasLimit let bh = ctxCurrentBlockHeight txCtx - let validSchemes = validPPKSchemes v cid bh + let validSchemes = validPPKSchemes v cid pact4ForkNumber bh let webAuthnPrefixLegal = isWebAuthnPrefixLegal v cid bh let P.PublicMeta pcid _ gl gp _ _ = P._pMeta pay @@ -174,7 +175,7 @@ assertTxSize initialGas gasLimit = initialGas < fromIntegral gasLimit -- transaction hash. -- assertValidateSigs :: () - => [P.PPKScheme] + => [PactPPKScheme] -> IsWebAuthnPrefixLegal -> P.PactHash -> [P.Signer] @@ -193,7 +194,7 @@ assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs = do iforM_ (zip sigs signers) $ \pos (sig, signer) -> do ebool_ (InvalidSignerScheme pos) - (fromMaybe P.ED25519 (P._siScheme signer) `elem` validSchemes) + ((SchemeV4 $ fromMaybe P.ED25519 $ P._siScheme signer) `elem` validSchemes) ebool_ (InvalidSignerWebAuthnPrefix pos) (webAuthnPrefixLegal == WebAuthnPrefixLegal || not (P.webAuthnPrefix `Text.isPrefixOf` P._siPubKey signer)) @@ -239,7 +240,7 @@ assertTxNotInFuture (ParentCreationTime (BlockCreationTime txValidationTime)) tx -- | Assert that the command hash matches its payload and -- its signatures are valid, without parsing the payload. -assertCommand :: P.Command (PayloadWithText m c) -> [P.PPKScheme] -> IsWebAuthnPrefixLegal -> Either AssertCommandError () +assertCommand :: P.Command (PayloadWithText m c) -> [PactPPKScheme] -> IsWebAuthnPrefixLegal -> Either AssertCommandError () assertCommand (P.Command pwt sigs hsh) ppkSchemePassList webAuthnPrefixLegal = do if isRight assertHash then first AssertValidateSigsError $ assertValidateSigs ppkSchemePassList webAuthnPrefixLegal hsh signers sigs diff --git a/src/Chainweb/Pact5/Types.hs b/src/Chainweb/Pact5/Types.hs index 12e9aed687..e937b5a862 100644 --- a/src/Chainweb/Pact5/Types.hs +++ b/src/Chainweb/Pact5/Types.hs @@ -89,7 +89,7 @@ ctxCurrentBlockHeight = succ . view blockHeight . ctxBlockHeader -- We use the parent fork number in Pact, so when the fork -- number is incremented, only that block's descendents will -- have the forking behavior active. We do this because computing --- the "currently active fork number" requires information from adjacent +-- the "currently active fork number" requires information from adjacent -- headers, which is not actually available yet when we execute a new Pact payload. ctxParentForkNumber :: TxContext -> ForkNumber ctxParentForkNumber = view blockForkNumber . ctxBlockHeader diff --git a/src/Chainweb/Pact5/Validations.hs b/src/Chainweb/Pact5/Validations.hs index bdafd74796..890be25b35 100644 --- a/src/Chainweb/Pact5/Validations.hs +++ b/src/Chainweb/Pact5/Validations.hs @@ -58,6 +58,7 @@ import qualified Pact.Core.Gas.Types as P import qualified Pact.Core.Hash as P import qualified Chainweb.Pact5.Transaction as P import qualified Pact.Types.Gas as Pact4 +import Chainweb.Version.Guards (PactPPKScheme(..), validPPKSchemes) import qualified Pact.Parse as Pact4 import Chainweb.Pact5.Types import qualified Chainweb.Pact5.Transaction as Pact5 @@ -79,6 +80,7 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do let P.PublicMeta pcid _ gl gp _ _ = P._pMeta pay nid = P._pNetworkId pay signers = P._pSigners pay + validSchemes = validPPKSchemes v cid (ctxParentForkNumber txCtx) (ctxCurrentBlockHeight txCtx) let errs = catMaybes [ eUnless "Chain id mismatch" $ assertChainId cid pcid @@ -88,7 +90,7 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do , eUnless "Gas price decimal precision too high" $ assertGasPrice gp , eUnless "Network id mismatch" $ assertNetworkId v nid , eUnless "Signature list size too big" $ assertSigSize sigs - , eUnless "Invalid transaction signatures" $ sigValidate signers + , eUnless "Invalid transaction signatures" $ sigValidate validSchemes signers , eUnless "Tx time outside of valid range" $ assertTxTimeRelativeToParent pct cmd ] @@ -96,9 +98,9 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do Nothing -> Right () Just vs -> Left vs where - sigValidate signers + sigValidate validSchemes signers | Just NoVerify <- sigVerify = True - | otherwise = isRight $ assertValidateSigs hsh signers sigs + | otherwise = isRight $ assertValidateSigs validSchemes hsh signers sigs pct = ParentCreationTime . view blockCreationTime @@ -153,11 +155,12 @@ assertTxSize initialGas gasLimit = P.GasLimit initialGas < gasLimit -- transaction hash. -- assertValidateSigs :: () - => P.Hash + => [PactPPKScheme] + -> P.Hash -> [P.Signer] -> [P.UserSig] -> Either AssertValidateSigsError () -assertValidateSigs hsh signers sigs = do +assertValidateSigs validSchemes hsh signers sigs = do let signersLength = length signers let sigsLength = length sigs ebool_ @@ -168,6 +171,9 @@ assertValidateSigs hsh signers sigs = do (signersLength == sigsLength) iforM_ (zip sigs signers) $ \pos (sig, signer) -> do + ebool_ (InvalidSignerScheme pos) + ((SchemeV5 $ fromMaybe P.ED25519 $ P._siScheme signer) `elem` validSchemes) + case P.verifyUserSig hsh sig signer of Left errMsg -> Left (InvalidUserSig pos (Text.pack errMsg)) Right () -> Right () @@ -209,10 +215,10 @@ assertTxNotInFuture (ParentCreationTime (BlockCreationTime txValidationTime)) tx -- | Assert that the command hash matches its payload and -- its signatures are valid, without parsing the payload. -assertCommand :: Pact5.Transaction -> Either AssertCommandError () -assertCommand cmd = do +assertCommand :: Pact5.Transaction -> [PactPPKScheme] -> Either AssertCommandError () +assertCommand cmd ppkSchemePassList = do _ <- assertHash & _Left .~ InvalidPayloadHash - assertValidateSigs hsh signers (P._cmdSigs cmd) & _Left %~ AssertValidateSigsError + assertValidateSigs ppkSchemePassList hsh signers (P._cmdSigs cmd) & _Left %~ AssertValidateSigsError where hsh = P._cmdHash cmd pwt = P._cmdPayload cmd diff --git a/src/Chainweb/Version/Guards.hs b/src/Chainweb/Version/Guards.hs index 3c1e631409..34a9e97f5a 100644 --- a/src/Chainweb/Version/Guards.hs +++ b/src/Chainweb/Version/Guards.hs @@ -53,10 +53,12 @@ module Chainweb.Version.Guards , chainweb31 , migratePlatformShare , pact5 + , getForkHeight , pact44NewTrans , pact4ParserVersion , maxBlockGasLimit , minimumBlockHeaderHistory + , PactPPKScheme(..) , validPPKSchemes , isWebAuthnPrefixLegal , validKeyFormats @@ -82,7 +84,8 @@ import Pact.Core.Builtin qualified as Pact5 import Pact.Core.Info qualified as Pact5 import Pact.Core.Serialise qualified as Pact5 import Pact.Types.KeySet (PublicKeyText, ed25519HexFormat, webAuthnFormat) -import Pact.Types.Scheme (PPKScheme(ED25519, WebAuthn)) +import Pact.Types.Scheme qualified as Pact4 (PPKScheme(..)) +import Pact.Core.Scheme qualified as Pact5 (PPKScheme(..)) -- Gets the height which the fork is associated with. -- This may not be the first height at which the associated guard is `True` @@ -305,6 +308,10 @@ chainweb225Pact = checkFork atOrAfter Chainweb225Pact pact5 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool pact5 = checkFork atOrAfter Pact5Fork +-- TODO Guard properly => For now, use the pact 5 fork +pactPostQuantum :: ChainwebVersion -> ChainId -> ForkNumber -> BlockHeight -> Bool +pactPostQuantum v cid _ bh = pact5 v cid bh + -- | Pact 5.1, including a new more succinct serializer for modules chainweb228Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool chainweb228Pact = checkFork atOrAfter Chainweb228Pact @@ -350,11 +357,15 @@ minimumBlockHeaderHistory v fn bh = snd $ ruleZipperHere $ snd -- | Different versions of Chainweb allow different PPKSchemes. -- -validPPKSchemes :: ChainwebVersion -> ChainId -> BlockHeight -> [PPKScheme] -validPPKSchemes v cid bh = - if chainweb221Pact v cid bh - then [ED25519, WebAuthn] - else [ED25519] +data PactPPKScheme = SchemeV4 Pact4.PPKScheme | SchemeV5 Pact5.PPKScheme + deriving(Eq) + +validPPKSchemes :: ChainwebVersion -> ChainId -> ForkNumber -> BlockHeight -> [PactPPKScheme] +validPPKSchemes v cid fn bh + | pactPostQuantum v cid fn bh = map SchemeV5 [Pact5.ED25519, Pact5.WebAuthn, Pact5.SlhDsaSha128s, Pact5.SlhDsaSha192s, Pact5.SlhDsaSha256s] + | pact5 v cid bh = map SchemeV5 [Pact5.ED25519, Pact5.WebAuthn] + | chainweb221Pact v cid bh = map SchemeV4 [Pact4.ED25519, Pact4.WebAuthn] + | otherwise = [SchemeV4 Pact4.ED25519] isWebAuthnPrefixLegal :: ChainwebVersion -> ChainId -> BlockHeight -> Pact4.IsWebAuthnPrefixLegal isWebAuthnPrefixLegal v cid bh = diff --git a/src/Chainweb/WebPactExecutionService.hs b/src/Chainweb/WebPactExecutionService.hs index 0e689c1775..1ee2956192 100644 --- a/src/Chainweb/WebPactExecutionService.hs +++ b/src/Chainweb/WebPactExecutionService.hs @@ -34,6 +34,7 @@ import Chainweb.BlockHeight import Chainweb.ChainId import Chainweb.Mempool.Mempool (InsertError) import Chainweb.Miner.Pact +import Chainweb.ForkState import Chainweb.Pact.Service.BlockValidation import Chainweb.Pact.Service.PactQueue import Chainweb.Pact.Types @@ -67,10 +68,10 @@ newBlockToPayloadWithOutputs (NewBlockInProgress bip) newBlockToPayloadWithOutputs (NewBlockPayload _ pwo) = pwo -newBlockParent :: NewBlock -> (BlockHash, BlockHeight, BlockCreationTime) +newBlockParent :: NewBlock -> (BlockHash, ForkNumber, BlockHeight, BlockCreationTime) newBlockParent (NewBlockInProgress (ForSomePactVersion _ bip)) = blockInProgressParent bip newBlockParent (NewBlockPayload (ParentHeader ph) _) = - (view blockHash ph, view blockHeight ph, view blockCreationTime ph) + (view blockHash ph, view blockForkNumber ph, view blockHeight ph, view blockCreationTime ph) instance HasChainwebVersion NewBlock where _chainwebVersion (NewBlockInProgress (ForSomePactVersion _ bip)) = _chainwebVersion bip diff --git a/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs b/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs index 879018055b..efae41b929 100644 --- a/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs +++ b/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs @@ -189,10 +189,12 @@ defaultCmd cid = CmdBuilder -- | Build parsed + verified Pact command -- TODO: Use the new `assertPact4Command` function. buildCwCmd :: (MonadThrow m, MonadIO m) => ChainwebVersion -> CmdBuilder -> m Pact5.Transaction -buildCwCmd v cmd = buildTextCmd v cmd >>= \(c :: Command Text) -> - case validatePact5Command v c of - Left err -> throwM $ userError $ "buildCwCmd failed: " ++ err - Right cmd' -> return cmd' +buildCwCmd v cmd = do + cid <- Chainweb.chainIdFromText $ _cbChainId cmd + cmd' <- buildTextCmd v cmd + case validatePact5Command v cid cmd' of + Left err -> throwM $ userError $ "buildCwCmd failed: " ++ err + Right validatedCmd -> return validatedCmd -- | Build a Pact4 command without parsing it. This can be useful for inserting txs directly into the mempool for testing. buildCwCmdNoParse :: forall m. (MonadThrow m, MonadIO m) => ChainwebVersion -> CmdBuilder -> m Pact4.UnparsedTransaction @@ -263,6 +265,10 @@ mkDynKeyPairs (CmdSigner Signer{..} privKey) = privWebAuthn <- either diePrivKey return (parseWebAuthnPrivateKey =<< parseB16TextOnly priv) return $ (DynWebAuthnKeyPair wasPrefixed pubWebAuthn privWebAuthn, _siCapList) + -- TODO Implement them + (SlhDsaSha128s, _, _) -> error "Unsupported" + (SlhDsaSha192s, _, _) -> error "Unsupported" + (SlhDsaSha256s, _, _) -> error "Unsupported" where diePubKey str = error $ "pubkey: " <> str diePrivKey str = error $ "privkey: " <> str diff --git a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs index c6db34af54..4819d5c637 100644 --- a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs @@ -474,7 +474,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> { -- This is an invalid ED25519 signature, -- but length signers == length signatures is checked first - _cmdSigs = [ED25519Sig "fakeSig"] + _cmdSigs = [PlainSig "fakeSig"] } send fx v cid [cmdSignersSigsLengthMismatch2] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains @@ -609,7 +609,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> validationFailed i cmd msg = "Transaction " <> sshow (_cmdHash cmd) <> " at index " <> sshow @Int i <> " failed with: " <> msg - mkCmdInvalidUserSig = mkCmdGood <&> set cmdSigs [ED25519Sig "fakeSig"] + mkCmdInvalidUserSig = mkCmdGood <&> set cmdSigs [PlainSig "fakeSig"] mkCmdGood = buildTextCmd v $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) @@ -1102,7 +1102,7 @@ localTests baseRdb = let goodCmdHash <- _cmdHash <$> buildTextCmd v buildSender00Cmd sender01KeyPair <- either error return $ importEd25519KeyPair Nothing (PrivBS $ either error id $ B16.decode $ T.encodeUtf8 $ snd sender01) - let sender01Sig = ED25519Sig $ T.decodeUtf8 $ B16.encode $ exportEd25519Signature $ + let sender01Sig = PlainSig $ T.decodeUtf8 $ B16.encode $ exportEd25519Signature $ signEd25519 (fst sender01KeyPair) (snd sender01KeyPair) goodCmdHash buildTextCmd v buildSender00Cmd