Guard the validSchemes for Pact5

Author: kdafriend

src/Chainweb/Pact/PactService.hs

@@ -860,7 +860,11 @@ 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
+                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 +907,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 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

src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs

@@ -531,7 +531,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 bh) hsh signers sigs of
           Right _ -> do
               pure ()
           Left err -> do

src/Chainweb/Pact/RestAPI/Server.hs

@@ -737,15 +737,18 @@ 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 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
+    bh = maxBound :: BlockHeight
+
 
 -- | Validate the length of the request key's underlying hash.
 --

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 $ ctxCurrentBlockHeight txCtx
 
     let errs = catMaybes
           [ eUnless "Chain id mismatch" $ assertChainId cid pcid
@@ -88,17 +90,17 @@ 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
           ]
 
     pure $ case nonEmpty errs of
       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

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