check defpacts for completion in preinsert check

src/Chainweb/Pact/Mempool/Mempool.hs

@@ -244,6 +244,7 @@ data InsertError
   | InsertErrorTimedOut
   | InsertErrorPactParseError Text
   | InsertErrorWrongChain Text Text
+  | InsertErrorDefPactComplete Text
   deriving (Generic, Eq, NFData)
 
 instance Show InsertError where
@@ -270,6 +271,8 @@ instance Show InsertError where
         , "It should be rounded to at most 12 decimal places."
         ]
       InsertErrorTooManySigs -> "Too many signatures"
+      InsertErrorDefPactComplete i ->
+        "This transaction is attempting to complete an already-completed defpact ID: " <> T.unpack i
 
 instance Exception InsertError
 

src/Chainweb/Pact/PactService.hs

@@ -106,17 +106,21 @@ import Network.HTTP.Client qualified as HTTP
 import P2P.TaskQueue (Priority(..))
 import Pact.Core.ChainData qualified as Pact
 import Pact.Core.Command.Types qualified as Pact
+import Pact.Core.Command.RPC qualified as Pact
 import Pact.Core.Errors qualified as Pact
 import Pact.Core.Evaluate qualified as Pact
 import Pact.Core.Gas qualified as Pact
 import Pact.Core.Hash qualified as Pact
+import Pact.Core.Names qualified as Pact
 import Pact.Core.StableEncoding qualified as Pact
 import Pact.JSON.Encode qualified as J
 import Prelude hiding (lookup)
 import System.LogLevel
 import Chainweb.Version.Guards (pact5)
 import Control.Concurrent.MVar (newMVar)
 import Chainweb.Pact.Payload.RestAPI.Client (payloadClient)
+import qualified Pact.Core.Persistence as Pact
+import qualified Pact.Core.Info as Pact
 
 withPactService
     :: (Logger logger, CanPayloadCas tbl)
@@ -790,13 +794,22 @@ execPreInsertCheckReq logger serviceEnv txs = do
     fakeParentCreationTime <- Checkpointer.mkFakeParentCreationTime
     let act sql = Checkpointer.readFromLatest logger cid sql fakeParentCreationTime $ Checkpointer.PactRead
             { pact5Read = \blockEnv bh -> do
-                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
-                        () <- mapExceptT liftIO
-                            $ Pact.validateParsedChainwebTx logger blockEnv tx
-                        evalStateT (attemptBuyGas blockEnv tx) bh
+                liftIO $ flip evalStateT bh $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pdb _ -> do
+                    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
+                            () <- mapExceptT liftIO
+                                $ Pact.validateParsedChainwebTx logger blockEnv tx
+                            evalStateT (attemptBuyGas blockEnv tx) bh
+                            case tx ^? Pact.cmdPayload . Pact.payloadObj . Pact.pPayload . Pact._Continuation of
+                                Just contMsg -> do
+                                    let pactId = Pact._cmPactId contMsg
+                                    defPactState <- liftIO $ Pact.ignoreGas (Pact.LineInfo 0) $ Pact._pdbRead pdb Pact.DDefPacts pactId
+                                    let isComplete = defPactState == Just Nothing
+                                    when isComplete $
+                                        throwError (InsertErrorDefPactComplete (sshow pactId))
+                                Nothing -> return ()
             -- pessimistically, if we're catching up and not even past the Pact
             -- 5 activation, just badlist everything as in-the-future.
             , pact4Read = \_ -> return $ Just InsertErrorTimeInFuture <$ txs

src/Chainweb/Utils.hs

@@ -1459,6 +1459,15 @@ instance Field3 (T3 a b c) (T3 a b x) c x where
 data T4 a b c d = T4 !a !b !c !d
     deriving (Show, Eq, Ord, Generic, NFData, Functor)
 
+instance Field1 (T4 a b c d) (T4 x b c d) a x where
+    _1 = lens (\(T4 a _b _c _d) -> a) (\(T4 _a b c d) x -> T4 x b c d)
+instance Field2 (T4 a b c d) (T4 a x c d) b x where
+    _2 = lens (\(T4 _a b _c _d) -> b) (\(T4 a _b c d) x -> T4 a x c d)
+instance Field3 (T4 a b c d) (T4 a b x d) c x where
+    _3 = lens (\(T4 _a _b c _d) -> c) (\(T4 a b _c d) x -> T4 a b x d)
+instance Field4 (T4 a b c d) (T4 a b c x) d x where
+    _4 = lens (\(T4 _a _b _c d) -> d) (\(T4 a b c _d) x -> T4 a b c x)
+
 sfst :: T2 a b -> a
 sfst (T2 a _) = a
 {-# INLINE sfst #-}