diff --git a/src/Chainweb/Pact/Mempool/Mempool.hs b/src/Chainweb/Pact/Mempool/Mempool.hs index 3ae72acc5f..54f8602abf 100644 --- a/src/Chainweb/Pact/Mempool/Mempool.hs +++ b/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 diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 2d7b9b28eb..bf98e895de 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -106,10 +106,12 @@ 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) @@ -117,6 +119,8 @@ 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 diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index a019c68516..1bd63e278e 100644 --- a/src/Chainweb/Utils.hs +++ b/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 #-}