fix resume pact arg issue

pact-core-tests/pact-tests/caps.repl

@@ -798,12 +798,12 @@
   (defun test-cap-guard (n:string m:string)
     (with-capability (CAP1 n)
       (enforce-guard (create-capability-guard (CAP1 m)))))
-  ;  (defpact cg-pact (kw:string kr:string n:string m:string)
-  ;    (step (write cg-tbl kw { 'g: (create-capability-pact-guard (CAP1 m)) }))
-  ;    (step
-  ;     (with-read cg-tbl kr { 'g := cg }
-  ;      (with-capability (CAP1 n) (enforce-guard cg))))
-  ;  )
+  (defpact cg-pact (kw:string kr:string n:string m:string)
+    (step (write cg-tbl kw { 'g: (create-capability-pact-guard (CAP1 m)) }))
+    (step
+     (with-read cg-tbl kr { 'g := cg }
+      (with-capability (CAP1 n) (enforce-guard cg))))
+  )
 )
 (create-table cg-tbl)
 
@@ -817,31 +817,31 @@
  "Capability not acquired"
  (test-cap-guard "A" "B"))
 
-;  (env-hash (hash 1))
+(env-hash (hash 1))
 
-;  (cg-pact 'k1 'k1 "C" "C")
-;  (expect
-;   "cap pact guard succeeds"
-;   true
-;   (continue-pact 1))
+(cg-pact 'k1 'k1 "C" "C")
+(expect
+ "cap pact guard succeeds"
+ true
+ (continue-pact 1))
 
-;  (pact-state true)
-;  (env-hash (hash 2))
+(pact-state true)
+(env-hash (hash 2))
 
-;  (cg-pact 'k2 'k2 "D" "E")
-;  (expect-failure
-;   "cap pact guard fails on wrong cap"
-;   "Capability not acquired"
-;   (continue-pact 1))
+(cg-pact 'k2 'k2 "D" "E")
+(expect-failure
+ "cap pact guard fails on wrong cap"
+ "Capability not acquired"
+ (continue-pact 1))
 
-;  (pact-state true)
-;  (env-hash (hash 3))
+(pact-state true)
+(env-hash (hash 3))
 
-;  (cg-pact 'k3 'k1 "C" "C")
-;  (expect-failure
-;   "cap pact guard fails on wrong pact id"
-;   "Invalid Pact ID"
-;   (continue-pact 1))
+(cg-pact 'k3 'k1 "C" "C")
+(expect-failure
+ "cap pact guard fails on wrong pact id"
+ "Invalid Pact ID"
+ (continue-pact 1))
 (commit-tx)
 
 (begin-tx)

pact-core/Pact/Core/Builtin.hs

@@ -237,6 +237,7 @@ data RawBuiltin
   | RawInstallCapability
   | RawEmitEvent
   | RawCreateCapabilityGuard
+  | RawCreateCapabilityPactGuard
   | RawCreateModuleGuard
   -- Database functions
   | RawCreateTable
@@ -356,6 +357,7 @@ rawBuiltinToText = \case
   RawEnforceKeyset -> "enforce-keyset"
   RawKeysetRefGuard -> "keyset-ref-guard"
   RawCreateCapabilityGuard -> "create-capability-guard"
+  RawCreateCapabilityPactGuard -> "create-capability-pact-guard"
   RawCreateModuleGuard -> "create-module-guard"
   RawAt -> "at"
   RawMakeList -> "make-list"
@@ -481,6 +483,7 @@ instance IsBuiltin RawBuiltin where
     RawEnforceGuard -> 1
     RawKeysetRefGuard -> 1
     RawCreateCapabilityGuard -> 1
+    RawCreateCapabilityPactGuard -> 1
     RawCreateModuleGuard -> 1
     RawAt -> 2
     RawMakeList -> 2

pact-core/Pact/Core/Errors.hs

@@ -212,6 +212,8 @@ instance Pretty DesugarError where
       Pretty.hsep ["Expected free variable in expression, found locally bound: ", pretty t]
     e -> pretty (show e)
 
+-- | Argument type mismatch meant for errors
+--   that does not force you to show the whole PactValue
 data ArgTypeError
   = ATEPrim PrimType
   | ATEList
@@ -329,8 +331,10 @@ data EvalError
   | InvalidEventCap FullyQualifiedName
   | NestedDefpactsNotAdvanced PactId
   | ExpectedPactValue
+  | NotInPactExecution
   deriving Show
 
+
 instance Pretty EvalError where
   pretty :: EvalError -> Pretty.Doc ann
   pretty = \case
@@ -359,14 +363,14 @@ instance Pretty EvalError where
       Pretty.hsep ["Native evaluation error for native", pretty n <> ",", "received incorrect argument(s) of type(s)", Pretty.commaSep tys]
     EvalError txt ->
       Pretty.hsep ["Program encountered an unhandled raised error:", pretty txt]
-    ModRefNotRefined _ -> error ""
-    InvalidDefKind _ _ -> error ""
-    NoSuchDef _ -> error ""
-    InvalidManagedCap _ -> error ""
-    CapNotInstalled _ -> error ""
-    NameNotInScope _ -> error ""
-    DefIsNotClosure _ -> error ""
-    NoSuchKeySet _ -> error ""
+    -- ModRefNotRefined _ -> error ""
+    -- InvalidDefKind _ _ -> error ""
+    -- NoSuchDef _ -> error ""
+    -- InvalidManagedCap _ -> error ""
+    -- CapNotInstalled _ -> error ""
+    -- NameNotInScope _ -> error ""
+    -- DefIsNotClosure _ -> error ""
+    -- NoSuchKeySet _ -> error ""
     YieldOutsiteDefPact ->
       "Try to yield a value outside a running DefPact execution"
     NoActivePactExec ->
@@ -433,22 +437,24 @@ instance Pretty EvalError where
       , "step: " <> pretty (_psStep ps)
       , "PactExec step: " <> pretty (_peStep pe + 1)
       ]
-    CannotUpgradeInterface _ -> error ""
-    ModuleGovernanceFailure _ -> error ""
-    DbOpFailure _ -> error ""
-    DynNameIsNotModRef _ -> error ""
-    ModuleDoesNotExist _ -> error ""
-    ExpectedModule _ -> error ""
-    HashNotBlessed _ _ -> error ""
-    CannotApplyPartialClosure -> error ""
-    ClosureAppliedToTooManyArgs -> error ""
-    FormIllegalWithinDefcap _ -> error ""
-    RunTimeTypecheckFailure _ _ -> error ""
-    NativeIsTopLevelOnly _ -> error ""
-    EventDoesNotMatchModule _ -> error ""
-    InvalidEventCap _ -> error ""
-    NestedDefpactsNotAdvanced _ -> error ""
-    ExpectedPactValue -> error ""
+    e -> pretty (show e)
+    -- CannotUpgradeInterface _ -> error ""
+    -- ModuleGovernanceFailure _ -> error ""
+    -- DbOpFailure _ -> error ""
+    -- DynNameIsNotModRef _ -> error ""
+    -- ModuleDoesNotExist _ -> error ""
+    -- ExpectedModule _ -> error ""
+    -- HashNotBlessed _ _ -> error ""
+    -- CannotApplyPartialClosure -> error ""
+    -- ClosureAppliedToTooManyArgs -> error ""
+    -- FormIllegalWithinDefcap _ -> error ""
+    -- RunTimeTypecheckFailure _ _ -> error ""
+    -- NativeIsTopLevelOnly _ -> error ""
+    -- EventDoesNotMatchModule _ -> error ""
+    -- InvalidEventCap _ -> error ""
+    -- NestedDefpactsNotAdvanced _ -> error ""
+    -- ExpectedPactValue -> error ""
+    -- NotInPactExecution -> error ""
 
 instance Exception EvalError
 
@@ -476,14 +482,8 @@ peInfo f = \case
     PEParseError pe <$> f info
   PEDesugarError de info ->
     PEDesugarError de <$> f info
-  -- PETypecheckError pe info ->
-  --   PETypecheckError pe <$> f info
-  -- PEOverloadError oe info ->
-  --   PEOverloadError oe <$> f info
   PEExecutionError ee info ->
     PEExecutionError ee <$> f info
-  -- PEFatalError fpe info ->
-  --   PEFatalError fpe <$> f info
 
 instance (Show info, Typeable info) => Exception (PactError info)
 

pact-core/Pact/Core/Guards.hs

@@ -140,9 +140,8 @@ data Namespace name term
   } deriving (Eq, Show)
 
 instance (Pretty name, Pretty term) => Pretty (CapabilityGuard name term) where
-  pretty (CapabilityGuard cg args) = "CapabilityGuard" <+> commaBraces
+  pretty (CapabilityGuard cg args pid) = "CapabilityGuard" <+> commaBraces
     [ "name: " <> pretty cg
     , "args: " <> pretty args
-    -- todo: pactId when I merge defpcats
-    -- , "pactId: " <> pretty _cgPactId
+    , "pactId: " <> pretty pid
     ]

pact-core/Pact/Core/IR/Desugar.hs

@@ -145,6 +145,7 @@ type MonadDesugar raw reso i m =
   , MonadError (PactError i) m
   , MonadState (RenamerState reso i) m
   , MonadReader (RenamerEnv reso i) m
+  , Show raw
   , Show reso
   , Show i
   , MonadIO m)
@@ -243,6 +244,8 @@ instance DesugarBuiltin (ReplBuiltin RawBuiltin) where
     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 RPactState) [e1] =
+    App (Builtin (RBuiltinRepl RResetPactState) i) [e1] i
   desugarAppArity i (RBuiltinRepl RContinuePact) [e1, e2, e3]
     | isn't _Lam e2 && isn't _Lam e3 =
       App (Builtin (RBuiltinRepl RContinuePactRollbackYield) i) [e1, e2, e3] i
@@ -1462,7 +1465,7 @@ runDesugar' pdb loaded act = do
   pure (DesugarOutput renamed loaded' deps)
 
 runDesugarTerm
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1471,7 +1474,7 @@ runDesugarTerm
 runDesugarTerm _ pdb loaded = runDesugar' pdb loaded  . RenamerT . (desugarLispTerm >=> renameTerm)
 
 runDesugarModule'
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1480,7 +1483,7 @@ runDesugarModule'
 runDesugarModule' _ pdb loaded = runDesugar' pdb loaded . RenamerT . (desugarModule >=> renameModule)
 
 runDesugarInterface
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1489,7 +1492,7 @@ runDesugarInterface
 runDesugarInterface _ pdb loaded  = runDesugar' pdb loaded . RenamerT . (desugarInterface >=> renameInterface)
 
 runDesugarReplDefun
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1502,7 +1505,7 @@ runDesugarReplDefun _ pdb loaded =
   . (desugarDefun >=> renameReplDefun)
 
 runDesugarReplDefConst
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1515,7 +1518,7 @@ runDesugarReplDefConst _ pdb loaded =
   . (desugarDefConst >=> renameReplDefConst)
 
 runDesugarTopLevel
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i
@@ -1530,7 +1533,7 @@ runDesugarTopLevel proxy pdb loaded = \case
 
 
 runDesugarReplTopLevel
-  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
+  :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i, Show raw)
   => Proxy raw
   -> PactDb reso i
   -> Loaded reso i

pact-core/Pact/Core/IR/Eval/CEK.hs

@@ -424,10 +424,11 @@ resumePact i cont handler env crossChainContinuation = viewCEKEnv eePactStep >>=
                  throwExecutionError i (DefPactStepMissmatch ps pe)
 
           let pc = view peContinuation pe
+              args = VPactValue <$> _pcArgs pc
               resume = case _psResume ps of
                          r@Just{} -> r
                          Nothing -> _peYield pe
-              env' = set cePactStep (Just $ set psResume resume ps) env
+              env' = set ceLocal (RAList.fromList (reverse args)) $ set cePactStep (Just $ set psResume resume ps) env
           applyPact i pc ps cont handler env' (_peNestedPactExec pe)
 
 

pact-core/Pact/Core/IR/Eval/RawBuiltin.hs

@@ -57,6 +57,7 @@ import Pact.Core.Capabilities
 
 import Pact.Core.IR.Term
 import Pact.Core.IR.Eval.Runtime
+import Pact.Core.StableEncoding
 import Pact.Core.IR.Eval.CEK
 
 import qualified Pact.Core.Pretty as Pretty
@@ -522,13 +523,6 @@ coreEnumerateStepN = \info b cont handler _env -> \case
     returnCEKValue cont handler (VList (PLiteral . LInteger <$> v))
   args -> argsError info b args
 
--- concatList :: (IsBuiltin b, MonadEval b i m) => b -> NativeFn b i m
--- concatList = \info b cont handler env -> \case
---   [VList li] -> do
---     li' <- traverse asList li
---     returnCEKValue cont handler (VList (V.concat (V.toList li')))
---   _ -> failInvariant "takeList"
-
 makeList :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m
 makeList = \info b cont handler _env -> \case
   [VLiteral (LInteger i), VPactValue v] -> do
@@ -737,16 +731,20 @@ enforceCapGuard
   -> CEKErrorHandler b i m
   -> CapabilityGuard FullyQualifiedName PactValue
   -> m (EvalResult b i m)
-enforceCapGuard info cont handler (CapabilityGuard fqn args) = do
-  -- let ct = CapToken (fqnToQualName fqn) args
-  cond <- isCapInStack (CapToken fqn args)
-  -- caps <- useEvalState (esCaps.csSlots)
-  -- let csToSet cs = S.insert (_csCap cs) (S.fromList (_csComposed cs))
-  --     capSet = foldMap csToSet caps
-  if cond then returnCEKValue cont handler (VBool True)
-  else do
-    let errMsg = "Capability guard enforce failure cap not in scope: " <> renderFullyQualName fqn
-    returnCEK cont handler (VError errMsg info)
+enforceCapGuard info cont handler (CapabilityGuard fqn args mpid) = do
+  case mpid of
+    Nothing -> enforceCap
+    Just pid -> do
+      currPid <- getPactId info
+      if currPid == pid then enforceCap
+      else returnCEK cont handler (VError "Capability pact guard failed: invalid pact id" info)
+  where
+  enforceCap = do
+    cond <- isCapInStack (CapToken fqn args)
+    if cond then returnCEKValue cont handler (VBool True)
+    else do
+      let errMsg = "Capability guard enforce failure cap not in scope: " <> renderFullyQualName fqn
+      returnCEK cont handler (VError errMsg info)
 
 runUserGuard
   :: MonadEval b i m
@@ -1088,10 +1086,18 @@ coreEmitEvent = \info b cont handler env -> \case
 createCapGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m
 createCapGuard = \info b cont handler _env -> \case
   [VCapToken ct] ->
-    let cg = CapabilityGuard (_ctName ct) (_ctArgs ct)
+    let cg = CapabilityGuard (_ctName ct) (_ctArgs ct) Nothing
     in returnCEKValue cont handler (VGuard (GCapabilityGuard cg))
   args -> argsError info b args
 
+createCapabilityPactGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m
+createCapabilityPactGuard = \info b cont handler _env -> \case
+  [VCapToken ct] -> do
+    pid <- getPactId info
+    let cg = CapabilityGuard (_ctName ct) (_ctArgs ct) (Just pid)
+    returnCEKValue cont handler (VGuard (GCapabilityGuard cg))
+  args -> argsError info b args
+
 createModuleGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m
 createModuleGuard = \info b cont handler _env -> \case
   [VString n] ->
@@ -1268,9 +1274,13 @@ coreWhere = \info b cont handler _env -> \case
 
 coreHash :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m
 coreHash = \info b cont handler _env -> \case
-  [VString s] -> do
-    returnCEKValue cont handler $ VString $ hashToText $ pactHash $ T.encodeUtf8 s
+  [VString s] ->
+    returnCEKValue cont handler (go (T.encodeUtf8 s))
+  [VPactValue pv] ->
+    returnCEKValue cont handler (go (encodeStable pv))
   args -> argsError info b args
+  where
+  go =  VString . hashToText . pactHash
 
 txHash :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m
 txHash = \info b cont handler _env -> \case
@@ -1489,6 +1499,7 @@ rawBuiltinRuntime = \case
   RawComposeCapability -> composeCapability
   RawInstallCapability -> installCapability
   RawCreateCapabilityGuard -> createCapGuard
+  RawCreateCapabilityPactGuard -> createCapabilityPactGuard
   RawCreateModuleGuard -> createModuleGuard
   RawEmitEvent -> coreEmitEvent
   RawCreateTable -> createTable