Chainweb Post-Quantum WIP

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

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

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

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

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

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

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,28 +720,37 @@ 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 <$>
         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 $ 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.
 --

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

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

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