wip nested pacts

kadena-io · Oct 17, 2023 · f1e0019 · f1e0019
1 parent 0c52c83
commit f1e0019
Show file tree

Hide file tree

Showing 6 changed files with 71 additions and 52 deletions.
diff --git a/pact-core-tests/pact-tests/nested-defpacts.repl b/pact-core-tests/pact-tests/nested-defpacts.repl
@@ -333,50 +333,50 @@
 
 
 ;; ; Case 1 test: module references
-;; (begin-tx)
-;; (expect "All is good for successful case 1: step 0" ["hello1-nested" "hello1-nested" "hello1"] (parent.good2))
-;; (expect "All is good for successful case 1: step 1" ["hello2-nested" "hello2-nested" "hello2"] (continue-pact 1))
-;; (expect "All is good for successful case 1: step 2" ["hello3-nested" "hello3-nested" "hello3"] (continue-pact 2))
-;; (commit-tx)
+(begin-tx)
+(expect "All is good for successful case 1: step 0" ["hello1-nested" "hello1-nested" "hello1"] (parent.good2))
+(expect "All is good for successful case 1: step 1" ["hello2-nested" "hello2-nested" "hello2"] (continue-pact 1))
+(expect "All is good for successful case 1: step 2" ["hello3-nested" "hello3-nested" "hello3"] (continue-pact 2))
+(commit-tx)
 
-;; ;  Case 1 test: different args
-;; (begin-tx)
-;; (expect "All is good for successful case 2: step 0" ["hello1-nesteda" "hello1-nestedb" "hello1-nested" "hello1"] (parent.good3))
-;; (expect "All is good for successful case 2: step 1" ["hello2-nesteda" "hello2-nestedb" "hello2-nested" "hello2"] (continue-pact 1))
-;; (expect "All is good for successful case 2: step 2" ["hello3-nesteda" "hello3-nestedb" "hello3-nested" "hello3"] (continue-pact 2))
-;; (commit-tx)
+;  Case 1 test: different args
+(begin-tx)
+(expect "All is good for successful case 2: step 0" ["hello1-nesteda" "hello1-nestedb" "hello1-nested" "hello1"] (parent.good3))
+(expect "All is good for successful case 2: step 1" ["hello2-nesteda" "hello2-nestedb" "hello2-nested" "hello2"] (continue-pact 1))
+(expect "All is good for successful case 2: step 2" ["hello3-nesteda" "hello3-nestedb" "hello3-nested" "hello3"] (continue-pact 2))
+(commit-tx)
 
-;; ; Case 1 test: good rollback
-;; (begin-tx)
-;; (expect "All is good for rollback success case" ["hello1-nested" "hello1-nested" "hello1"] (parent.good-rollback))
-;; (expect "All is good for rollback success case" ["hello2-nested" "hello2-nested" "hello2"] (continue-pact 1))
-;; (expect "All is good for rollback success case" ["hello3-nested" "hello3-nested" "hello3"] (continue-pact 2))
-;; (commit-tx)
+; Case 1 test: good rollback
+(begin-tx)
+(expect "All is good for rollback success case" ["hello1-nested" "hello1-nested" "hello1"] (parent.good-rollback))
+(expect "All is good for rollback success case" ["hello2-nested" "hello2-nested" "hello2"] (continue-pact 1))
+(expect "All is good for rollback success case" ["hello3-nested" "hello3-nested" "hello3"] (continue-pact 2))
+(commit-tx)
 
-;; ; Case 1 test: good rollback
-;; (begin-tx)
-;; (expect "All is good for rollback: step 0 executes before rollback" ["hello1-nested" "hello1-nested" "hello1"] (parent.good-rollback))
-;; (expect "All is good for rollback: step 0 rolls back" ["hello1rollback-nested" "hello1rollback-nested" "hello1"] (continue-pact 0 true))
-;; (commit-tx)
+; Case 1 test: good rollback
+(begin-tx)
+(expect "All is good for rollback: step 0 executes before rollback" ["hello1-nested" "hello1-nested" "hello1"] (parent.good-rollback))
+(expect "All is good for rollback: step 0 rolls back" ["hello1rollback-nested" "hello1rollback-nested" "hello1"] (continue-pact 0 true))
+(commit-tx)
 
-;; ; Case 1 test: good rollback
-;; (begin-tx)
-;; (expect "All is good for rollback step 1 case: step 0 executes" ["hello1-nested" "hello1-nested" "hello1"] (parent.good-rollback))
-;; (expect "All is good for rollback step 1 case: step 1 executes" ["hello2-nested" "hello2-nested" "hello2"] (continue-pact 1))
-;; (expect "All is good for rollback step 1 case: step 1 rollbacks"  ["hello2rollback-nested" "hello2rollback-nested" "hello2"] (continue-pact 1 true))
-;; (commit-tx)
+; Case 1 test: good rollback
+(begin-tx)
+(expect "All is good for rollback step 1 case: step 0 executes" ["hello1-nested" "hello1-nested" "hello1"] (parent.good-rollback))
+(expect "All is good for rollback step 1 case: step 1 executes" ["hello2-nested" "hello2-nested" "hello2"] (continue-pact 1))
+(expect "All is good for rollback step 1 case: step 1 rollbacks"  ["hello2rollback-nested" "hello2rollback-nested" "hello2"] (continue-pact 1 true))
+(commit-tx)
 
-;; ; Case 2 test
-;; (begin-tx)
-;; (expect "Case 2: step 0" ["hello1-nested" "hello1-nested" "hello1"] (parent.bad-parent))
-;; (expect-failure "Case 2: step 1" "Nested defpacts were not all advanced in prior step for pact" (continue-pact 1))
-;; (commit-tx)
+; Case 2 test
+(begin-tx)
+(expect "Case 2: step 0" ["hello1-nested" "hello1-nested" "hello1"] (parent.bad-parent))
+(expect-failure "Case 2: step 1" "Nested defpacts were not all advanced in prior step for pact" (continue-pact 1))
+(commit-tx)
 
-;; ; Case 3 test
-;; (begin-tx)
-;; (expect "Case 3: step 0" ["hello1-nested" "hello1-nested" "hello1"] (parent.bad1))
-;; (expect-failure "Case 3: step 1" "Nested defpacts were not all advanced in prior step for pact" (continue-pact 1))
-;; (commit-tx)
+; Case 3 test
+;  (begin-tx)
+;  (expect "Case 3: step 0" ["hello1-nested" "hello1-nested" "hello1"] (parent.bad1))
+;  (expect-failure "Case 3: step 1" "Nested defpacts were not all advanced in prior step for pact" (continue-pact 1))
+;  (commit-tx)
 
 ;; ; Case 4 test
 ;; (begin-tx)

diff --git a/pact-core/Pact/Core/Builtin.hs b/pact-core/Pact/Core/Builtin.hs
@@ -545,7 +545,6 @@ data ReplBuiltins
   -- | RBeginTx
   -- | RBench
   -- | RCommitTx
-  -- | RContinuePact
   -- | REnvExecConfig
   -- | REnvGas
   -- | REnvGasLimit
@@ -556,6 +555,7 @@ data ReplBuiltins
   -- | REnvNamespacePolicy
   -- Defpact
   | RContinuePact
+  | RContinuePactRollback
   | RPactState
   | RResetPactState
   deriving (Show, Enum, Bounded, Eq)
@@ -585,6 +585,7 @@ instance IsBuiltin ReplBuiltins where
     RRollbackTx -> 0
     RSigKeyset -> 1
     RTestCapability -> 1
+    RContinuePactRollback -> 2
     -- RLoad -> 1
     -- RLoadWithEnv -> 2
 -- Note: commented out natives are
@@ -649,6 +650,7 @@ replBuiltinsToText = \case
   RRollbackTx -> "rollback-tx"
   RSigKeyset -> "sig-keyset"
   RTestCapability -> "test-capability"
+  RContinuePactRollback -> "continue-pact-with-rollback"
   -- RLoad -> "load"
   -- RLoadWithEnv -> "load-with-env"
 

diff --git a/pact-core/Pact/Core/Errors.hs b/pact-core/Pact/Core/Errors.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE GADTs #-}
 -- {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE InstanceSigs #-}
 
 module Pact.Core.Errors
  ( PactErrorI
@@ -31,6 +32,7 @@ import Pact.Core.Info
 import Pact.Core.Pretty(Pretty(..))
 import Pact.Core.Hash
 import Pact.Core.Persistence
+import Pact.Core.Pacts.Types
 
 import qualified Pact.Core.Pretty as Pretty
 
@@ -288,9 +290,11 @@ data EvalError
   | NativeIsTopLevelOnly NativeName
   | EventDoesNotMatchModule ModuleName
   | InvalidEventCap FullyQualifiedName
+  | NestedDefpactsNotAdvanced PactId
   deriving Show
 
 instance Pretty EvalError where
+  pretty :: EvalError -> Pretty.Doc ann
   pretty = \case
     ArrayOutOfBoundsException len ix ->
       Pretty.hsep

diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs
@@ -239,6 +239,8 @@ instance DesugarBuiltin (ReplBuiltin RawBuiltin) where
     App (Builtin (RBuiltinRepl RExpectFailure) i) [e1, suspendTerm e2] i
   desugarAppArity i (RBuiltinRepl RExpectFailure) [e1, e2, e3] | isn't _Lam e2 =
     App (Builtin (RBuiltinRepl RExpectFailureMatch) i) [e1, e2, suspendTerm e3] i
+  desugarAppArity i (RBuiltinRepl RContinuePact) [e1, e2] | isn't _Lam e2 =
+    App (Builtin (RBuiltinRepl RContinuePactRollback) i) [e1, e2] i
   -- desugarAppArity i (RBuiltinRepl RContinuePact) (e1 :| e2)  =
   --   App (Builtin (RBuiltinRepl RContinuePact) i) (e1 :| e2) i
   desugarAppArity i b ne =
@@ -1408,7 +1410,7 @@ checkImplements i defs ifaceName =
         Just (Dfun v) ->
           when (_dfunArgs v /= _ifdArgs ifd || _dfunRType v /= _ifdRType ifd) $ error "function args dont match"
         Just _ -> error "not implemented"
-        Nothing -> error "not implemented" 
+        Nothing -> error "not implemented"
     IfDCap ifd ->
       case find (\df -> _ifdcName ifd == defName df) defs of
         Just (DCap v) ->

diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs
@@ -253,7 +253,7 @@ initPact i pc cont handler cenv = do
       let
         pStep = PactStep 0 False (hashToPactId pHash) Nothing
         cenv' = set cePactStep (Just pStep) cenv
-      applyPact i pc pStep cont handler cenv'
+      applyPact i pc pStep cont handler cenv' mempty
     Just ps ->
       let
         npId = mkNestedPactId pc (_psPactId ps)
@@ -268,8 +268,9 @@ applyPact
   -> Cont b i m
   -> CEKErrorHandler b i m
   -> CEKEnv b i m
+  -> M.Map PactId PactExec
   -> m (EvalResult b i m)
-applyPact i pc ps cont handler cenv = useEvalState esPactExec >>= \case
+applyPact i pc ps cont handler cenv nested = useEvalState esPactExec >>= \case
   Just _ ->  throwExecutionError i MultipleOrNestedPactExecFound
   Nothing -> lookupFqName (pc ^. pcName) >>= \case
     Just (DPact defPact) -> do
@@ -292,7 +293,7 @@ applyPact i pc ps cont handler cenv = useEvalState esPactExec >>= \case
                , _peStep = _psStep ps
                , _pePactId = _psPactId ps
                , _peContinuation = pc
-               , _peNestedPactExec = mempty
+               , _peNestedPactExec = nested
                }
 
       setEvalState esPactExec (Just pe)
@@ -317,8 +318,8 @@ applyNestedPact
   -> CEKErrorHandler b i m
   -> CEKEnv b i m
   -> m (EvalResult b i m)
-applyNestedPact i pc ps cont handler cenv = trace (show pc) $ useEvalState esPactExec >>= \case
-  Nothing -> failInvariant i "applyNestedPact: Nested Pact attempted but no pactExec found"
+applyNestedPact i pc ps cont handler cenv = useEvalState esPactExec >>= \case
+  Nothing -> failInvariant i $ "applyNestedPact: Nested Pact attempted but no pactExec found" <> T.pack (show pc)
   Just pe -> lookupFqName (pc ^. pcName) >>= \case
     Just (DPact defPact) -> do
       step <- maybe (failInvariant i "Step not found") pure
@@ -331,7 +332,6 @@ applyNestedPact i pc ps cont handler cenv = trace (show pc) $ useEvalState esPac
         failInvariant i "applyNestedPact: invalid nested defpact length, must be equal to length of parent"
       when (isRollback /= _peStepHasRollback pe) $
         error "applyNestedPact: invalid nested defpact step, must match parent rollback"
-
       exec <- case pe ^. peNestedPactExec . at (_psPactId ps) of
         Nothing
           | _psStep ps == 0 -> pure $ PactExec
@@ -347,7 +347,8 @@ applyNestedPact i pc ps cont handler cenv = trace (show pc) $ useEvalState esPac
         Just npe
           | _psStep ps >= 0 && isRollback && _peStep npe == _psStep ps ->
             pure (set peStepHasRollback isRollback npe)
-          | _psStep ps >  0 && _peStep npe + 1 == _psStep ps -> pure (over peStep (+1) npe)
+          | _psStep ps >  0 && _peStep npe + 1 == _psStep ps ->
+            pure (over peStep (+1) $ set peStepHasRollback isRollback $ npe)
           | otherwise -> failInvariant i "nested pact never started at prior step"
 
       setEvalState esPactExec (Just exec)
@@ -413,7 +414,7 @@ resumePact i cont handler env crossChainContinuation = viewCEKEnv eePactStep >>=
                          r@Just{} -> r
                          Nothing -> _peYield pe
               env' = set cePactStep (Just $ set psResume resume ps) env
-          applyPact i pc ps cont handler env'
+          applyPact i pc ps cont handler env' (_peNestedPactExec pe)
 
 
 enforceKeyset
@@ -1033,7 +1034,8 @@ returnCEKValue (PactStepC env cont) handler v =
           pdb = view cePactDb env
           isLastStep = _psStep ps == pred (_peStepCount pe)
           done = (not (_psRollback ps) && isLastStep) || _psRollback ps
-
+        when (nestedPactsNotAdvanced pe ps) $
+          throwExecutionError def (NestedDefpactsNotAdvanced (_pePactId pe))
         liftDbFunction def
           (writePacts pdb Write (_psPactId ps)
             (if done then Nothing else Just pe))
@@ -1046,12 +1048,19 @@ returnCEKValue (NestedPactStepC env cont parentPactExec) handler v =
     Just pe ->  case env ^. cePactStep of
       Nothing -> failInvariant def "Expected a PactStep in the environment"
       Just ps -> do
+        when (nestedPactsNotAdvanced pe ps) $
+          throwExecutionError def (NestedDefpactsNotAdvanced (_pePactId pe))
         let npe = parentPactExec & peNestedPactExec %~ M.insert (_psPactId ps) pe
         setEvalState esPactExec (Just npe)
-
         -- TODO: check nestedPactsNotAdvanced
         returnCEKValue cont handler v
 
+-- | Important check for nested pacts:
+--     - Nested step must be equal to the parent step after execution.
+nestedPactsNotAdvanced :: PactExec -> PactStep -> Bool
+nestedPactsNotAdvanced resultState ps =
+  any (\npe -> _peStep npe /= _psStep ps) (_peNestedPactExec resultState)
+{-# INLINE nestedPactsNotAdvanced #-}
 
 applyLam
   :: (MonadEval b i m)

diff --git a/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs
@@ -133,9 +133,10 @@ continuePact info b cont handler env = \case
           in pure (pid, yield)
       let pactStep = PactStep (fromInteger step) rollback pid myield
       setEvalState esPactExec Nothing
-
       (reEnv . eePactStep) .= Just pactStep
-      resumePact info cont handler env Nothing
+      s <- resumePact info cont handler env Nothing
+      (reEnv . eePactStep) .= Nothing
+      pure s
 
 pactState :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i)
 pactState = \ info b _cont _handler _env -> \case
@@ -369,3 +370,4 @@ replRawBuiltinRuntime = \case
     RRollbackTx -> rollbackTx
     RSigKeyset -> sigKeyset
     RTestCapability -> testCapability
+    RContinuePactRollback -> continuePact