Forked errors on chain (#1185)

* wip fix args error

* more forked errors

* fix tests

* fix tests

* remove top level native docs on chain

* Add tests for env-in-repl doc protections

* forking more errors

* remove bool blindness

* change in-repl function name

* fork native docs

* env simulate on chain

* Address John's comments

---------

Co-authored-by: Emily Pillmore <[email protected]>

Author: jmcardon

docs/en/pact-functions.md

@@ -1916,7 +1916,7 @@ Retreive any accumulated events and optionally clear event state. Object returne
  *→* `[string]`
 
 
-Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact420","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePactEvents","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"]
+Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact420","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePactEvents","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"]
 ```lisp
 pact> (env-exec-config ['DisableHistoryInTransactionalMode]) (env-exec-config)
 ["DisableHistoryInTransactionalMode"]
@@ -2039,6 +2039,17 @@ Set transaction signature keys and capabilities. SIGS is a list of objects with
 ```
 
 
+### env-simulate-onchain {#env-simulate-onchain}
+
+*on-chain* `bool` *→* `string`
+
+
+Set a flag to simulate on-chain behavior that differs from the repl, in particular for observing things like errors and stack traces.
+```lisp
+(env-simulate-onchain true)
+```
+
+
 ### expect {#expect}
 
 *doc*&nbsp;`string` *expected*&nbsp;`<a>` *actual*&nbsp;`<a>` *&rarr;*&nbsp;`string`

src/Pact/Eval.hs

@@ -33,6 +33,7 @@ module Pact.Eval
     (eval
     ,evalBeginTx,evalRollbackTx,evalCommitTx
     ,reduce,reduceBody
+    ,reduceEnscoped
     ,resolveFreeVars,resolveArg,resolveRef
     ,enforceKeySet,enforceKeySetName
     ,enforceGuard
@@ -346,7 +347,19 @@ eval' (TModule _tm@(MDInterface m) bod i) =
     writeRow i Write Modules (_interfaceName mangledI) =<< traverse (traverse toPersistDirect') govI
     endAdvice govI
     return (g, msg $ "Loaded interface " <> pretty (_interfaceName mangledI))
-eval' t = enscope t >>= reduce
+eval' t = enscope t >>= reduceEnscoped
+
+reduceEnscoped :: Term Ref -> Eval e (Term Name)
+reduceEnscoped = \case
+  TVar (Direct t'@TNative{}) i ->
+    isOffChainForkedError >>= \case
+      OnChainError -> evalError' i "Cannot display native function details in non-repl context"
+      OffChainError -> pure t'
+  TVar (Ref t'@TDef{}) i ->
+    isOffChainForkedError >>= \case
+      OnChainError -> evalError' i "Cannot display function details in non-repl context"
+      OffChainError -> toTerm <$> compatPretty t'
+  t' -> reduce t'
 
 -- | Enforce namespace/root access on install.
 enforceNamespaceInstall
@@ -1037,8 +1050,14 @@ reduce t@TLiteral {} = unsafeReduce t
 reduce t@TGuard {} = unsafeReduce t
 reduce TLam{..} = evalError _tInfo "Cannot reduce bound lambda"
 reduce TList {..} = TList <$> mapM reduce _tList <*> traverse reduce _tListType <*> pure _tInfo
-reduce t@TDef {} = toTerm <$> compatPretty t
-reduce t@TNative {} = toTerm <$> compatPretty t
+reduce t@TDef {} =
+  isExecutionFlagSet FlagDisablePact47 >>= \case
+    True -> toTerm <$> compatPretty t
+    False -> evalError' (_tInfo t) "Cannot display function details in non-repl context"
+reduce t@TNative {} =
+  isExecutionFlagSet FlagDisablePact47 >>= \case
+    True -> toTerm <$> compatPretty t
+    False -> evalError' (_tInfo t) "Cannot display native function details in non-repl context"
 reduce TConst {..} = case _tConstVal of
   CVEval _ t -> reduce t
   CVRaw a -> evalError _tInfo $ "internal error: reduce: unevaluated const: " <> pretty a
@@ -1053,7 +1072,7 @@ reduce t@TStep {} = evalError (_tInfo t) "Step at invalid location"
 reduce TSchema {..} = TSchema _tSchemaName _tModule _tMeta <$> traverse (traverse reduce) _tFields <*> pure _tInfo
 reduce TTable {..} = TTable _tTableName _tModuleName _tHash <$> mapM reduce _tTableType <*> pure _tMeta <*> pure _tInfo
 reduce t@TModRef{} = unsafeReduce t
-reduce (TDynamic tref tmem i)  = reduceDynamic tref tmem i >>= \rd -> case rd of
+reduce (TDynamic tref tmem i)  = reduceDynamic tref tmem i >>= \case
   Left v -> return v
   Right d -> reduce (TDef d (getInfo d))
 

src/Pact/Native.hs

@@ -164,7 +164,9 @@ enforceDef = defNative "enforce" enforce
             return (TLiteral (LBool True) def)
           else reduce msg >>= \case
             TLitString msg' -> failTx (_faInfo i) $ pretty msg'
-            e -> evalError' i $ "Invalid message argument, expected string " <> pretty e
+            e -> isOffChainForkedError >>= \case
+              OffChainError -> evalError' i $ "Invalid message argument, expected string " <> pretty e
+              OnChainError -> evalError' i $ "Invalid message argument, expected string, received argument of type: " <> pretty (typeof' e)
         cond' -> reduce msg >>= argsError i . reverse . (:[cond'])
     enforceLazy i as = mapM reduce as >>= argsError i
 
@@ -344,8 +346,11 @@ ifDef = defNative "if" if' (funType a [("cond",tTyBool),("then",a),("else",a)])
 
     if' :: NativeFun e
     if' i as@[cond,then',else'] = gasUnreduced i as $ reduce cond >>= \case
-               TLiteral (LBool c') _ -> reduce (if c' then then' else else')
-               t -> evalError' i $ "if: conditional not boolean: " <> pretty t
+      TLiteral (LBool c') _ -> reduce (if c' then then' else else')
+      t -> isOffChainForkedError >>= \case
+        OffChainError -> evalError' i $ "if: conditional not boolean: " <> pretty t
+        OnChainError -> evalError' i $ "if: conditional not boolean, received value of type: " <> pretty (typeof' t)
+
     if' i as = argsError' i as
 
 
@@ -529,8 +534,9 @@ defineNamespaceDef = setTopLevelOnly $ defGasRNative "define-namespace" defineNa
       asBool =<< apply (App def' [] i) mkArgs
       where
         asBool (TLiteral (LBool allow) _) = return allow
-        asBool t = evalError' fi $
-          "Unexpected return value from namespace policy: " <> pretty t
+        asBool t = isOffChainForkedError >>= \case
+          OffChainError -> evalError' fi $ "Unexpected return value from namespace policy: " <> pretty t
+          OnChainError -> evalError' fi $ "Unexpected return value from namespace policy, received value of type: " <> pretty (typeof' t)
 
         mkArgs = [toTerm (asString nn),TGuard (_nsAdmin ns) def]
 
@@ -902,9 +908,12 @@ b = mkTyVar "b" []
 c = mkTyVar "c" []
 
 map' :: NativeFun e
-map' i as@[tLamToApp -> TApp app _,l] = gasUnreduced i as $ reduce l >>= \l' -> case l' of
+map' i as@[tLamToApp -> TApp app _,l] = gasUnreduced i as $ reduce l >>= \case
            TList ls _ _ -> (\b' -> TList b' TyAny def) <$> forM ls (apply app . pure)
-           t -> evalError' i $ "map: expecting list: " <> pretty (abbrev t)
+           t ->
+            isOffChainForkedError >>= \case
+              OffChainError -> evalError' i $ "map: expecting list: " <> pretty (abbrev t)
+              OnChainError -> evalError' i $ "map: expecting list, received argument of type: " <> pretty (typeof' t)
 map' i as = argsError' i as
 
 list :: RNativeFun e
@@ -964,7 +973,10 @@ fold' :: NativeFun e
 fold' i as@[tLamToApp -> app@TApp {},initv,l] = gasUnreduced i as $ reduce l >>= \case
            TList ls _ _ -> reduce initv >>= \initv' ->
                          foldM (\r a' -> apply (_tApp app) [r,a']) initv' ls
-           t -> evalError' i $ "fold: expecting list: " <> pretty (abbrev t)
+           t ->
+            isOffChainForkedError >>= \case
+              OffChainError -> evalError' i $ "fold: expecting list: " <> pretty (abbrev t)
+              OnChainError -> evalError' i $ "fold: expecting list, received argument of type: " <> pretty (typeof' t)
 fold' i as = argsError' i as
 
 
@@ -977,7 +989,9 @@ filter' i as@[tLamToApp -> app@TApp {},l] = gasUnreduced i as $ reduce l >>= \ca
       _ -> ifExecutionFlagSet FlagDisablePact420
              (return False)
              (evalError' i $ "filter: expected closure to return bool: " <> pretty app)
-  t -> evalError' i $ "filter: expecting list: " <> pretty (abbrev t)
+  t -> isOffChainForkedError >>= \case
+      OffChainError -> evalError' i $ "filter: expecting list: " <> pretty (abbrev t)
+      OnChainError -> evalError' i $ "filter: expecting list, received argument of type: " <> pretty (typeof' t)
 filter' i as = argsError' i as
 
 
@@ -1084,8 +1098,9 @@ bind i as = argsError' i as
 bindObjectLookup :: Term Name -> Eval e (Text -> Maybe (Term Name))
 bindObjectLookup (TObject (Object (ObjectMap o) _ _ _) _) =
   return $ \s -> M.lookup (FieldKey s) o
-bindObjectLookup t = evalError (_tInfo t) $
-  "bind: expected object: " <> pretty t
+bindObjectLookup t = isOffChainForkedError >>= \case
+  OffChainError -> evalError (_tInfo t) $ "bind: expected object: " <> pretty t
+  OnChainError -> evalError (_tInfo t) $ "bind: expected object, received value of type: " <> pretty (typeof' t)
 
 typeof'' :: RNativeFun e
 typeof'' _ [t] = return $ tStr $ typeof' t
@@ -1242,7 +1257,9 @@ concat' g i [TList ls _ _] = computeGas' g i (GMakeList $ fromIntegral $ V.lengt
   concatTextList = flip TLiteral def . LString . T.concat
   in fmap concatTextList $ forM ls' $ \case
     TLitString s -> return s
-    t -> evalError' i $ "concat: expecting list of strings: " <> pretty t
+    t -> isOffChainForkedError >>= \case
+      OffChainError -> evalError' i $ "concat: expecting list of strings: " <> pretty t
+      OnChainError -> evalError' i $ "concat: expected list of strings, received value of type: " <> pretty (typeof' t)
 concat' _ i as = argsError i as
 
 -- | Converts a string to a vector of single character strings
@@ -1375,6 +1392,7 @@ continueNested i as = gasUnreduced i as $ case as of
     TDynamic tref tmem ti -> reduceDynamic tref tmem ti >>= \case
       Right d -> pure d
       Left _ -> evalError' i $ "continue: dynamic reference did not point to Defpact"
+    -- Note, pretty on `t` is not dangerous here, as it is not a reduced term.
     _ -> evalError' i $ "continue: argument must be a defpact " <> pretty t
   unTVar = \case
     TVar (Ref d) _ -> unTVar d

src/Pact/Native/Db.hs

@@ -249,15 +249,19 @@ foldDB' :: NativeFun e
 foldDB' i [tbl, tLamToApp -> TApp qry _, tLamToApp -> TApp consumer _] = do
   table <- reduce tbl >>= \case
     t@TTable{} -> return t
-    t -> evalError' i $ "Expected table as first argument to foldDB, got: " <> pretty t
+    t -> isOffChainForkedError >>= \case
+      OffChainError -> evalError' i $ "Expected table as first argument to foldDB, got: " <> pretty t
+      OnChainError -> evalError' i $ "Expected table as first argument to foldDB, got argument of type: " <> pretty (typeof' t)
   !g0 <- computeGas (Right i) (GUnreduced [])
   !g1 <- computeGas (Right i) GFoldDB
   ks <- getKeys table
   (!g2, xs) <- foldlM (fdb table) (g0+g1, []) ks
   pure (g2, TList (V.fromList (reverse xs)) TyAny def)
   where
   asBool (TLiteral (LBool satisfies) _) = return satisfies
-  asBool t = evalError' i $ "Unexpected return value from fold-db query condition " <> pretty t
+  asBool t = isOffChainForkedError >>= \case
+    OffChainError -> evalError' i $ "Unexpected return value from fold-db query condition " <> pretty t
+    OnChainError -> evalError' i $ "Unexpected return value from fold-db query condition, received value of type: " <> pretty (typeof' t)
   getKeys table = do
     guardTable i table GtKeys
     keys (_faInfo i) (userTable table)
@@ -336,8 +340,9 @@ select' i _ cols' app@TApp{} tbl@TTable{} = do
                   Nothing -> return (obj:rs)
                   Just cols -> (:rs) <$> columnsToObject' tblTy cols row
               | otherwise -> return rs
-            t -> evalError (_tInfo app) $ "select: filter returned non-boolean value: "
-                 <> pretty t
+            t -> isOffChainForkedError >>= \case
+              OffChainError -> evalError (_tInfo app) $ "select: filter returned non-boolean value: " <> pretty t
+              OnChainError -> evalError (_tInfo app) $ "select: filter returned non-boolean value: " <> pretty (typeof' t)
 select' i as _ _ _ = argsError' i as
 
 
@@ -472,7 +477,9 @@ guardTable i TTable {..} dbop =
             _ | localBypassEnabled -> return ()
               | otherwise -> notBypassed
 
-guardTable i t _ = evalError' i $ "Internal error: guardTable called with non-table term: " <> pretty t
+guardTable i t _ = isOffChainForkedError >>= \case
+  OffChainError -> evalError' i $ "Internal error: guardTable called with non-table term: " <> pretty t
+  OnChainError -> evalError' i $ "Internal error: guardTable called with non-table term: " <> pretty (typeof' t)
 
 enforceBlessedHashes :: FunApp -> ModuleName -> ModuleHash -> Eval e ()
 enforceBlessedHashes i mn h = getModule i mn >>= \m -> case (_mdModule m) of

src/Pact/Repl/Lib.hs

@@ -270,6 +270,10 @@ replDefs = ("Repl",
       [LitExample "(env-dynref fungible-v2 coin)"]
       ("Substitute module IMPL in any dynamic usages of IFACE in typechecking and analysis. " <>
        "With no arguments, remove all substitutions.")
+     ,defZRNative "env-simulate-onchain" envSimulateOnChain
+       (funType tTyString [("on-chain", tTyBool)])
+       [LitExample "(env-simulate-onchain true)"]
+       "Set a flag to simulate on-chain behavior that differs from the repl, in particular for observing things like errors and stack traces."
      ])
      where
        json = mkTyVar "a" [tTyInteger,tTyString,tTyTime,tTyDecimal,tTyBool,
@@ -545,8 +549,8 @@ testCatch i doc expr errMsg cont = catchesPactError expr >>= \r -> case r of
 expect :: ZNativeFun LibState
 expect i as@[_,b',c'] = do
   doc <- testDoc i as
-  testCatch i doc (reduce c') "evaluation of actual failed" $ \c ->
-    testCatch i doc (reduce b') "evaluation of expected failed" $ \b ->
+  testCatch i doc (reduceEnscoped c') "evaluation of actual failed" $ \c ->
+    testCatch i doc (reduceEnscoped b') "evaluation of expected failed" $ \b ->
       if b `termEq` c
       then testSuccess doc "Expect"
       else testFailure i doc $
@@ -565,7 +569,7 @@ expectFail i as = case as of
     tsuccess msg = testSuccess msg "Expect failure"
     go errM expr = do
       msg' <- testDoc i as
-      r <- catch (Right <$> reduce expr) (\(e :: SomeException) -> return $ Left (show e))
+      r <- catch (Right <$> reduceEnscoped expr) (\(e :: SomeException) -> return $ Left (show e))
       case r of
         Right v -> testFailure i msg' $ "expected failure, got result = " <> pretty v
         Left e -> case errM of
@@ -579,7 +583,7 @@ expectFail i as = case as of
 expectThat :: ZNativeFun LibState
 expectThat i as@[_,tLamToApp -> TApp pred' predi,expr'] = do
   doc <- testDoc i as
-  testCatch i doc (reduce expr') "evaluation of expression failed" $ \v ->
+  testCatch i doc (reduceEnscoped expr') "evaluation of expression failed" $ \v ->
     testCatch i doc (apply pred' [v]) "evaluation of predicate failed" $ \p -> case p of
       TLitBool b
           | b -> testSuccess doc $ "Expect-that"
@@ -867,3 +871,11 @@ withEnv _ [exec] = do
     _ -> (ls,Endo id)
   local (appEndo updates) $ reduce exec
 withEnv i as = argsError' i as
+
+envSimulateOnChain :: RNativeFun LibState
+envSimulateOnChain _i [TLiteral (LBool simulateOnChain) _] = do
+  -- Note: Simulating on-chain means we are _not_ `inRepl`
+  setenv eeInRepl (not simulateOnChain)
+  let ppInRepl = if simulateOnChain then "true" else "false"
+  return $ tStr $ "Set on-chain simulation execution mode to: " <> ppInRepl
+envSimulateOnChain i as = argsError i as

src/Pact/Types/Capability.hs

@@ -181,7 +181,7 @@ data Capabilities = Capabilities
     -- initialized from signature set.
   , _capModuleAdmin :: (Set ModuleName)
     -- ^ Set of module admin capabilities.
-  , _capAutonomous :: (Set UserCapability)
+  , _capAutonomous :: Set UserCapability
   }
   deriving (Eq,Show,Generic)
 

src/Pact/Types/Runtime.hs

@@ -55,7 +55,9 @@ module Pact.Types.Runtime
    module Pact.Types.ChainMeta,
    module Pact.Types.PactError,
    liftIO,
-   eAdvise
+   eAdvise,
+   isOffChainForkedError,
+   OnChainErrorState(..)
    ) where
 
 
@@ -77,6 +79,7 @@ import Data.Text (Text,pack)
 import Data.Set(Set)
 import GHC.Generics (Generic)
 
+import Pact.Types.Term
 import Pact.Types.Capability
 import Pact.Types.ChainMeta
 import Pact.Types.Continuation
@@ -180,8 +183,10 @@ data ExecutionFlag
   | FlagDisableNewTrans
   -- | Disable Pact 4.5 Features
   | FlagDisablePact45
-    -- | Disable Pact 4.6 Features
+  -- | Disable Pact 4.6 Features
   | FlagDisablePact46
+  -- | Disable Pact 4.7 Features
+  | FlagDisablePact47
   deriving (Eq,Ord,Show,Enum,Bounded)
 
 -- | Flag string representation
@@ -434,17 +439,44 @@ throwArgsError FunApp {..} args s = throwErr ArgsError _faInfo $
   pretty s <> ", received " <> bracketsSep (map pretty args) <> " for " <>
             prettyFunTypes _faTypes
 
+throwOnChainArgsError :: Pretty n => FunApp -> [Term n] -> Eval e a
+throwOnChainArgsError FunApp{..} args = throwErr ArgsError _faInfo $
+  "Invalid arguments in call to"
+    <+> pretty _faName
+    <> ", received arguments of type "
+    <> bracketsSep (map (pretty . typeof') args) <> ", expected "
+    <> prettyFunTypes _faTypes
+
 throwErr :: PactErrorType -> Info -> Doc -> Eval e a
-throwErr ctor i err = get >>= \s -> throwM (PactError ctor i (_evalCallStack s) err)
+throwErr ctor i err = do
+  s <- use evalCallStack
+  offChainOrPreFork <- isOffChainForkedError'
+  throwM (PactError ctor i (if offChainOrPreFork then s else []) err)
 
 evalError :: Info -> Doc -> Eval e a
-evalError i = throwErr EvalError i
+evalError = throwErr EvalError
 
 evalError' :: HasInfo i => i -> Doc -> Eval e a
 evalError' = evalError . getInfo
 
+data OnChainErrorState
+  = OnChainError
+  | OffChainError
+  deriving (Eq, Show)
+
+-- | Function to determine whether we are either pre-errors fork
+-- or in a repl environment.
+isOffChainForkedError :: Eval e OnChainErrorState
+isOffChainForkedError = isOffChainForkedError' <&> \p -> if p then OffChainError else OnChainError
+
+isOffChainForkedError' :: Eval e Bool
+isOffChainForkedError' =
+  isExecutionFlagSet FlagDisablePact47 >>= \case
+    True -> pure True
+    False -> view eeInRepl
+
 failTx :: Info -> Doc -> Eval e a
-failTx i = throwErr TxFailure i
+failTx = throwErr TxFailure
 
 failTx' :: HasInfo i => i -> Doc -> Eval e a
 failTx' = failTx . getInfo
@@ -461,10 +493,16 @@ throwEitherText typ i d = either (\e -> throwErr typ i (d <> ":" <> pretty e)) r
 
 
 argsError :: FunApp -> [Term Name] -> Eval e a
-argsError i as = throwArgsError i as "Invalid arguments"
+argsError i as =
+  isOffChainForkedError >>= \case
+    OffChainError -> throwArgsError i as "Invalid arguments"
+    OnChainError -> throwOnChainArgsError i as
 
 argsError' :: FunApp -> [Term Ref] -> Eval e a
-argsError' i as = throwArgsError i (map (toTerm.abbrev) as) "Invalid arguments"
+argsError' i as =
+  isOffChainForkedError >>= \case
+    OffChainError -> throwArgsError i (map (toTerm.abbrev) as) "Invalid arguments"
+    OnChainError -> throwOnChainArgsError i as
 
 eAdvise :: Info -> AdviceContext r -> Eval e (r -> Eval e ())
 eAdvise i m = view eeAdvice >>= \adv -> advise i adv m