Better Management of Signature schemes

bench/Chainweb/Pact/Backend/PactService.hs

@@ -82,7 +82,7 @@ bench :: RocksDb -> C.Benchmark
 bench rdb = do
     C.bgroup "PactService"
         [ C.bgroup "Pact4"
-            [ C.bench "1 tx" $ oneBlock pact4Version rdb 1
+           $ (const []) [ C.bench "1 tx" $ oneBlock pact4Version rdb 1  -- Temporaily disabled
             , C.bench "10 txs" $ oneBlock pact4Version rdb 10
             , C.bench "20 txs" $ oneBlock pact4Version rdb 20
             , C.bench "30 txs" $ oneBlock pact4Version rdb 30

src/Chainweb/Pact/PactService.hs

@@ -108,6 +108,7 @@ import Chainweb.Pact.Service.PactQueue (PactQueue, getNextRequest)
 import Chainweb.Pact.Types
 import Chainweb.Pact4.SPV qualified as Pact4
 import Chainweb.Pact5.SPV qualified as Pact5
+import Chainweb.ForkState (pact4ForkNumber)
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
 import Chainweb.Time
@@ -817,7 +818,8 @@ 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 isValidScheme = isValidPPKScheme v cid pact4ForkNumber bh . SchemeV4
+                        let validated = Pact4.assertCommand pact4Cwtx isValidScheme (isWebAuthnPrefixLegal v cid bh)
                         case validated of
                             Left err -> earlyReturn $ review _MetadataValidationFailure (pure $ displayAssertCommandError err)
                             Right () -> return ()
@@ -859,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
+                spvSupport = Pact5.pactSPV bhdb (_parentHeader ph)
+                pact5RequestKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx)
+
             evalContT $ withEarlyReturn $ \earlyReturn -> do
                 pact5Cmd <- case Pact5.parsePact4Command cwtx of
                     Left (Left errText) -> do
@@ -902,14 +909,14 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
                                 review _MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err
                             Right _ -> return ()
                     _ -> do
-                        let validated = Pact5.assertCommand pact5Cmd
+                        let isValidScheme = isValidPPKScheme v cid fn bh . SchemeV5
+                            validated = Pact5.assertCommand pact5Cmd isValidScheme
+
                         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
@@ -1180,13 +1187,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

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

@@ -328,7 +328,7 @@ checkTxSigs
   -> f ()
 checkTxSigs logger v cid bh t = do
   liftIO $ logFunctionText logger Debug $ "Pact4.checkTxSigs: " <> sshow (Pact4._cmdHash t)
-  case Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs of
+  case Pact4.assertValidateSigs isValidScheme webAuthnPrefixLegal hsh signers sigs of
       Right _ -> do
           pure ()
       Left err -> do
@@ -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
+    isValidScheme = isValidPPKScheme v cid pact4ForkNumber bh . SchemeV4
     webAuthnPrefixLegal = isWebAuthnPrefixLegal v cid bh
 
 checkCompile

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
@@ -478,13 +479,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
@@ -532,12 +535,13 @@ 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 isValidScheme hsh signers sigs of
           Right _ -> do
               pure ()
           Left err -> do
               throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err)
       where
+        isValidScheme = isValidPPKScheme v cid fn bh . SchemeV5
         hsh = Pact5._cmdHash t
         sigs = Pact5._cmdSigs t
         signers = Pact5._pSigners $ view Pact5.payloadObj $ Pact5._cmdPayload t
@@ -559,17 +563,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
@@ -595,7 +601,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

src/Chainweb/Pact/RestAPI/Server.hs

@@ -119,8 +119,9 @@ import qualified Chainweb.TreeDB as TreeDB
 import Chainweb.Utils
 import Chainweb.Version
 import qualified Chainweb.Pact4.Validations as Pact4
-import Chainweb.Version.Guards (isWebAuthnPrefixLegal, validPPKSchemes)
+import Chainweb.Version.Guards (isWebAuthnPrefixLegal, isValidPPKScheme)
 import Chainweb.WebPactExecutionService
+import Chainweb.ForkState (pact4ForkNumber)
 
 import qualified Pact.JSON.Encode as J
 import qualified Pact.Parse as Pact4
@@ -718,27 +719,34 @@ 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 isValidScheme (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
+    isValidScheme = isValidPPKScheme v cid pact4ForkNumber bh . SchemeV4
+    -- It's a Pact4 function, make sure it always execute in the context of Pact4
+    bh = case afterFork v Pact5Fork of
+          ForkAtBlockHeight x -> x - 1
+          ForkNever -> maxBound
+          _  -> error "Incompatible Pact 4 version"
+
     decodeAndParse bs =
         traverse (Pact4.parsePact) =<< Aeson.eitherDecodeStrict' bs
     parsedCmd = Pact4.mkPayloadWithText <$>
         Pact4.cmdPayload (\bs -> (bs,) <$> decodeAndParse bs) cmdBs
 
 -- 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 isValidScheme)
     then Right commandParsed
     else Left "Command failed validation"
   Left e -> Left $ "Pact parsing error: " ++ Pact5.renderCompactString e
   where
+    isValidScheme = isValidPPKScheme _v cid maxBound maxBound . SchemeV5
     parsedCmd = Pact5.parseCommand cmdText
 
 -- | Validate the length of the request key's underlying hash.

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
@@ -264,6 +265,7 @@ import Chainweb.Payload
 import Data.ByteString.Short (ShortByteString)
 import qualified Data.ByteString.Short as SB
 import qualified Data.Vector as V
+--import qualified Pact.Core.Hash as Pact5
 import Data.Maybe
 import Chainweb.BlockCreationTime
 import qualified Data.Aeson as Aeson
@@ -1188,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

src/Chainweb/Pact4/Validations.hs

@@ -63,8 +63,8 @@ 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 (isWebAuthnPrefixLegal, isValidPPKScheme)
+import Chainweb.ForkState (pact4ForkNumber)
 import qualified Pact.Types.Gas as P
 import qualified Pact.Types.Hash as P
 import qualified Pact.Types.ChainId as P
@@ -89,7 +89,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 isValidScheme = isValidPPKScheme v cid pact4ForkNumber bh . SchemeV4
     let webAuthnPrefixLegal = isWebAuthnPrefixLegal v cid bh
 
     let P.PublicMeta pcid _ gl gp _ _ = P._pMeta pay
@@ -104,17 +104,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 validSchemes webAuthnPrefixLegal signers
+          , eUnless "Invalid transaction signatures" $ sigValidate isValidScheme webAuthnPrefixLegal signers
           , eUnless "Tx time outside of valid range" $ assertTxTimeRelativeToParent pct cmd
           ]
 
     pure $ case nonEmpty errs of
       Nothing -> Right ()
       Just vs -> Left vs
   where
-    sigValidate validSchemes webAuthnPrefixLegal signers
+    sigValidate isValidScheme webAuthnPrefixLegal signers
       | Just NoVerify <- sigVerify = True
-      | otherwise = isRight $ assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs
+      | otherwise = isRight $ assertValidateSigs isValidScheme webAuthnPrefixLegal hsh signers sigs
 
     pct = ParentCreationTime
       . view blockCreationTime
@@ -174,13 +174,13 @@ assertTxSize initialGas gasLimit = initialGas < fromIntegral gasLimit
 -- transaction hash.
 --
 assertValidateSigs :: ()
-  => [P.PPKScheme]
+  => (P.PPKScheme -> Bool)
   -> IsWebAuthnPrefixLegal
   -> P.PactHash
   -> [P.Signer]
   -> [P.UserSig]
   -> Either AssertValidateSigsError ()
-assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs = do
+assertValidateSigs isValidScheme webAuthnPrefixLegal hsh signers sigs = do
   let signersLength = length signers
   let sigsLength = length sigs
   ebool_
@@ -193,7 +193,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)
+      (isValidScheme $ fromMaybe P.ED25519 $ P._siScheme signer)
     ebool_
       (InvalidSignerWebAuthnPrefix pos)
       (webAuthnPrefixLegal == WebAuthnPrefixLegal || not (P.webAuthnPrefix `Text.isPrefixOf` P._siPubKey signer))
@@ -239,10 +239,10 @@ 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 pwt sigs hsh) ppkSchemePassList webAuthnPrefixLegal = do
+assertCommand :: P.Command (PayloadWithText m c) -> (P.PPKScheme -> Bool) -> IsWebAuthnPrefixLegal -> Either AssertCommandError ()
+assertCommand (P.Command pwt sigs hsh) isValidScheme webAuthnPrefixLegal = do
   if isRight assertHash
-  then first AssertValidateSigsError $ assertValidateSigs ppkSchemePassList webAuthnPrefixLegal hsh signers sigs
+  then first AssertValidateSigsError $ assertValidateSigs isValidScheme webAuthnPrefixLegal hsh signers sigs
   else Left InvalidPayloadHash
   where
     cmdBS = SBS.fromShort $ payloadBytes pwt