Switch to uncheckedinsert for newblock invalid tx test, add new test

src/Chainweb/Mempool/InMem.hs

@@ -498,9 +498,9 @@ insertInMem logger cfg lock runCheck txs0 = do
             recordRecentTransactions maxRecent newHashes
   where
     insertCheck :: IO (Vector (T2 TransactionHash t))
-    insertCheck = if runCheck == CheckedInsert
-                  then insertCheckInMem' cfg lock txs0
-                  else return $! V.map (\tx -> T2 (hasher tx) tx) txs0
+    insertCheck = case runCheck of
+      CheckedInsert -> insertCheckInMem' cfg lock txs0
+      UncheckedInsert -> return $! V.map (\tx -> T2 (hasher tx) tx) txs0
 
     txcfg = _inmemTxCfg cfg
     encodeTx = codecEncode (txCodec txcfg)

src/Chainweb/Mempool/Mempool.hs

@@ -240,6 +240,7 @@ data InsertError
   | InsertErrorInvalidSigs
   | InsertErrorTimedOut
   | InsertErrorPactParseError Text
+  | InsertErrorWrongChain Text Text
   deriving (Generic, Eq, NFData)
 
 instance Show InsertError where
@@ -259,6 +260,7 @@ instance Show InsertError where
       InsertErrorInvalidSigs -> "Invalid transaction sigs"
       InsertErrorTimedOut -> "Transaction validation timed out"
       InsertErrorPactParseError msg -> "Pact parse error: " <> T.unpack msg
+      InsertErrorWrongChain expected actual -> "Wrong chain, expected: " <> T.unpack expected <> ", actual: " <> T.unpack actual
 
 instance Exception InsertError
 

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

@@ -12,6 +12,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- Module: Chainweb.Pact.PactService.Pact4.ExecBlock
@@ -253,11 +254,23 @@ validateParsedChainwebTx logger v cid dbEnv txValidationTime bh tx
   | otherwise = do
       checkUnique logger dbEnv tx
       checkTxHash logger v cid bh tx
+      checkChain cid tx
       checkTxSigs logger v cid bh tx
       checkTimes logger v cid bh txValidationTime tx
       _ <- checkCompile logger v cid bh tx
       return ()
 
+checkChain
+  :: ChainId
+  -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta code)
+  -> ExceptT InsertError IO ()
+checkChain cid
+  (view (Pact4.cmdPayload . to Pact4.payloadObj . Pact4.pMeta . Pact4.pmChainId) -> txCid)
+  | Pact4.assertChainId cid txCid =
+    return ()
+  | otherwise =
+    throwError $ InsertErrorWrongChain (chainIdToText cid) (Pact4._chainId txCid)
+
 checkUnique
   :: (Logger logger)
   => logger

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

@@ -88,6 +88,7 @@ import Chainweb.Pact5.NoCoinbase
 import qualified Pact.Core.Errors as Pact5
 import qualified Pact.Core.Evaluate as Pact5
 import Chainweb.Pact.Backend.Types
+import qualified Pact.Core.ChainData as Pact5
 
 -- | Calculate miner reward. We want this to error hard in the case where
 -- block times have finally exceeded the 120-year range. Rewards are calculated
@@ -493,11 +494,21 @@ validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime bh isGen
   | otherwise = do
       checkUnique tx
       checkTxHash tx
+      checkChain
       checkTxSigs tx
       checkTimes tx
       return ()
   where
 
+    checkChain :: ExceptT InsertError IO ()
+    checkChain
+      | Pact5.assertChainId cid txCid =
+        return ()
+      | otherwise =
+        throwError $ InsertErrorWrongChain (chainIdToText cid) (Pact5._chainId txCid)
+      where
+      txCid = view (Pact5.cmdPayload . Pact5.payloadObj . Pact5.pMeta . Pact5.pmChainId) tx
+
     checkUnique :: Pact5.Transaction -> ExceptT InsertError IO ()
     checkUnique t = do
       found <- liftIO $

test/unit/Chainweb/Test/Pact5/PactServiceTest.hs

@@ -130,7 +130,7 @@ tests baseRdb = testGroup "Pact5 PactServiceTest"
     , testCase "continue block spec" (continueBlockSpec baseRdb)
     , testCase "new block empty" (newBlockEmpty baseRdb)
     , testCase "new block timeout spec" (newBlockTimeoutSpec baseRdb)
-    , testCase "mempool excludes invalid transactions" (testMempoolExcludesInvalid baseRdb)
+    , testCase "new block excludes invalid transactions" (testNewBlockExcludesInvalid baseRdb)
     , testCase "lookup pact txs spec" (lookupPactTxsSpec baseRdb)
     , testCase "failed txs should go into blocks" (failedTxsShouldGoIntoBlocks baseRdb)
     ]
@@ -278,8 +278,8 @@ newBlockTimeoutSpec baseRdb = runResourceT $ do
 
         pure ()
 
-testMempoolExcludesInvalid :: RocksDb -> IO ()
-testMempoolExcludesInvalid baseRdb = runResourceT $ do
+testNewBlockExcludesInvalid :: RocksDb -> IO ()
+testNewBlockExcludesInvalid baseRdb = runResourceT $ do
     fixture <- mkFixture baseRdb
     liftIO $ do
         -- The mempool should reject a tx that doesn't parse as valid pact.
@@ -321,15 +321,17 @@ testMempoolExcludesInvalid baseRdb = runResourceT $ do
                 ]
             }
 
+        badChain <- buildCwCmd v $ transferCmd 1.0 & set cbChainId (unsafeChainId 1)
+
         let pact4Hash = Pact5.Hash . Pact4.unHash . Pact4.toUntypedHash . Pact4._cmdHash
         _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do
             mempoolInsert5 mempool CheckedInsert [regularTx1]
             bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue
             return $ finalizeBlock bip
 
         _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do
-            mempoolInsert mempool CheckedInsert $ Vector.fromList [badParse, badSigs]
-            mempoolInsert5 mempool CheckedInsert [badUnique, badFuture, badPast, badTxHash]
+            mempoolInsert mempool UncheckedInsert $ Vector.fromList [badParse, badSigs]
+            mempoolInsert5 mempool UncheckedInsert [badChain, badUnique, badFuture, badPast, badTxHash]
             bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue
             let expectedTxs = []
             let actualTxs = Vector.toList $ Vector.map (unRequestKey . _crReqKey . snd) $ _transactionPairs $ _blockInProgressTransactions bip