Improve callstack errors, check for recursion.

gasmodel/Pact/Core/GasModel/InterpreterGas.hs

@@ -355,7 +355,7 @@ gasMtWithHandlerValue pdb = do
                     , _ceInCap=False
                     , _ceDefPactStep=ps
                     , _ceBuiltins=benchmarkEnv }
-        handler = CEKHandler env unitConst Mt (ErrorState def []) CEKNoHandler
+        handler = CEKHandler env unitConst Mt (ErrorState def [] (pure def)) CEKNoHandler
     pure (ee, es, frame, handler, value)
 
 -- Gas for a lambda with N
@@ -375,7 +375,7 @@ gasMtWithHandlerError pdb =
                     , _ceInCap=False
                     , _ceDefPactStep=ps
                     , _ceBuiltins=benchmarkEnv }
-        handler = CEKHandler env unitConst Mt (ErrorState def []) CEKNoHandler
+        handler = CEKHandler env unitConst Mt (ErrorState def [] (pure def)) CEKNoHandler
     pure (ee, es, frame, handler, value)
 
 gasArgsWithRemainingArgs :: PactDb CoreBuiltin () -> C.Benchmark

gasmodel/Pact/Core/GasModel/Utils.hs

@@ -74,6 +74,7 @@ defaultGasEvalState =
   , _esDefPactExec=Nothing
   , _esCaps=capState
   , _esGasLog=Nothing
+  , _esCheckRecursion = pure (RecursionCheck mempty)
   }
   where
   capState = CapState [] mempty (S.singleton gmModuleName) mempty
@@ -342,8 +343,7 @@ runNativeBenchmarkPrepared envVars = runNativeBenchmark' pure stMod
 unitClosureNullary :: CEKEnv step CoreBuiltin () m -> Closure step CoreBuiltin () m
 unitClosureNullary env
   = Closure
-  { _cloFnName = "foo"
-  , _cloModName = ModuleName "foomodule" Nothing
+  { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash
   , _cloTypes = NullaryClosure
   , _cloArity = 0
   , _cloTerm = unitConst
@@ -355,8 +355,7 @@ unitClosureNullary env
 unitClosureUnary :: CEKEnv step CoreBuiltin () m -> Closure step CoreBuiltin () m
 unitClosureUnary env
   = Closure
-  { _cloFnName = "foo"
-  , _cloModName = ModuleName "foomodule" Nothing
+  { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash
   , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg" Nothing ()])
   , _cloArity = 1
   , _cloTerm = unitConst
@@ -367,8 +366,7 @@ unitClosureUnary env
 unitClosureBinary :: CEKEnv step CoreBuiltin () m -> Closure step CoreBuiltin () m
 unitClosureBinary env
   = Closure
-  { _cloFnName = "foo"
-  , _cloModName = ModuleName "foomodule" Nothing
+  { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash
   , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing (), Arg "fooCloArg2" Nothing ()])
   , _cloArity = 2
   , _cloTerm = unitConst
@@ -380,8 +378,7 @@ unitClosureBinary env
 boolClosureUnary :: Bool -> CEKEnv step b () m -> Closure step b () m
 boolClosureUnary b env
   = Closure
-  { _cloFnName = "foo"
-  , _cloModName = ModuleName "foomodule" Nothing
+  { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash
   , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing ()])
   , _cloArity = 1
   , _cloTerm = boolConst b
@@ -392,8 +389,7 @@ boolClosureUnary b env
 boolClosureBinary :: Bool -> CEKEnv step b () m -> Closure step b () m
 boolClosureBinary b env
   = Closure
-  { _cloFnName = "foo"
-  , _cloModName = ModuleName "fooModule" Nothing
+  { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash
   , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing (), Arg "fooCloArg2" Nothing ()])
   , _cloArity = 2
   , _cloTerm = boolConst b
@@ -404,8 +400,7 @@ boolClosureBinary b env
 intClosureBinary :: Integer -> CEKEnv step b () m -> Closure step b () m
 intClosureBinary b env
   = Closure
-  { _cloFnName = "foo"
-  , _cloModName = ModuleName "fooModule" Nothing
+  { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash
   , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing (), Arg "fooCloArg2" Nothing ()])
   , _cloArity = 2
   , _cloTerm = intConst b

pact-tests/Pact/Core/Test/ReplTests.hs

@@ -94,7 +94,7 @@ runReplTest pdb file src interp = do
   ensurePassing = \case
     RCompileValue (InterpretValue v i) -> case v of
       PLiteral (LString msg) -> do
-        let render = replError (SourceCode file src) (PEExecutionError (EvalError msg) i)
+        let render = replError (SourceCode file src) (PEExecutionError (EvalError msg) [] i)
         when (T.isPrefixOf "FAILURE:" msg) $ assertFailure (T.unpack render)
       _ -> pure ()
     _ -> pure ()

pact-tests/pact-tests/modref-recursion.repl

@@ -0,0 +1,32 @@
+
+(interface call
+
+  (defun callF:integer (m:module{call}))
+  )
+
+(module knot1 g
+  (defcap g () true)
+
+  (implements call)
+
+  (defun callF:integer (m:module{call})
+    (+ 1 2) ; call something so it costs gas
+    (m::callF knot1)
+  )
+  )
+
+(module knot2 g
+  (defcap g () true)
+
+  (implements call)
+
+  (defun callF:integer (m:module{call})
+    (+ 1 2) ; call something so it costs gas
+    (m::callF knot2)
+  )
+  )
+
+(env-gasmodel "table")
+(env-gaslimit 10) ; ensures test does not run forever in case recursion breaks
+
+(expect-failure "Recursion should fail @ runtime" (knot2.callF knot1))

pact-tests/pact-tests/repl-toplevels.repl

@@ -3,4 +3,10 @@
 
 (defun repl-defun1:integer (a:integer b:integer) (+ a b))
 
-(expect "repl-consts work with repl defuns" 3 (repl-defun1 repl-const1 (repl-defun1 repl-const1 repl-const1)))
+(expect "repl-consts work with repl defuns" 3
+  (let
+    (
+    (v1 (repl-defun1 repl-const1 repl-const1))
+    )
+    (repl-defun1 repl-const1 v1))
+  )

pact-tng.cabal

@@ -174,6 +174,7 @@ library
     Pact.Core.Scheme
     Pact.Core.Repl
     Pact.Core.SizeOf
+    Pact.Core.StackFrame
     Pact.Core.Legacy.LegacyPactValue
     Pact.Core.Legacy.LegacyCodec
 

pact/Pact/Core/Environment/Types.hs

@@ -21,8 +21,6 @@ module Pact.Core.Environment.Types
  , eePublicData, eeMode, eeFlags
  , eeNatives, eeGasModel
  , eeNamespacePolicy, eeGasRef
- , PactState(..)
- , psLoaded
  , TxCreationTime(..)
  , PublicData(..)
  , pdPublicMeta, pdBlockHeight
@@ -47,6 +45,7 @@ module Pact.Core.Environment.Types
  , MonadEval
  , defaultEvalEnv
  , GasLogEntry(..)
+ , RecursionCheck(..)
  ) where
 
 
@@ -56,6 +55,7 @@ import Control.Monad.IO.Class
 import Data.Set(Set)
 import Data.Text(Text)
 import Data.Map.Strict(Map)
+import Data.List.NonEmpty (NonEmpty(..))
 import Data.IORef
 import Data.Default
 
@@ -77,6 +77,7 @@ import Pact.Core.Errors
 import Pact.Core.Gas
 import Pact.Core.Namespace
 import Pact.Core.SizeOf
+import Pact.Core.StackFrame
 import Pact.Core.Builtin (IsBuiltin)
 
 -- | Execution flags specify behavior of the runtime environment,
@@ -96,6 +97,8 @@ data ExecutionFlag
   | FlagEnforceKeyFormats
   -- | Require keysets to be defined in namespaces
   | FlagRequireKeysetNs
+  -- | Flag disabling return type checking
+  | FlagDisableRTC
   deriving (Eq,Ord,Show,Enum,Bounded, Generic)
 
 instance NFData ExecutionFlag
@@ -136,57 +139,51 @@ data EvalEnv b i
   , _eeGasRef :: IORef MilliGas
   -- ^ The gas ref
   , _eeGasModel :: GasModel b
+  -- ^ The current gas model
   } deriving (Generic)
 
 instance (NFData b, NFData i) => NFData (EvalEnv b i)
 
 makeLenses ''EvalEnv
 
-newtype PactState b i
-  = PactState
-  { _psLoaded :: Loaded b i
-  }
-
-makeLenses ''PactState
-
-data StackFunctionType
-  = SFDefun
-  | SFDefcap
-  | SFDefPact
-  deriving (Eq, Show, Enum, Bounded, Generic)
-
-instance NFData StackFunctionType
-
-data StackFrame
-  = StackFrame
-  { _sfFunction :: Text
-  , _sfModule :: ModuleName
-  , _sfFnType :: StackFunctionType }
-  deriving (Show, Generic)
-
-instance NFData StackFrame
 
 data GasLogEntry b = GasLogEntry
   { _gleCause :: Either GasArgs b
   , _gleThisUsed :: MilliGas
   , _gleTotalUsed :: MilliGas
   } deriving (Show, Generic, NFData)
 
+newtype RecursionCheck
+  = RecursionCheck (Set QualifiedName)
+  deriving (Show, Generic, NFData)
+
+instance Default RecursionCheck where
+  def = RecursionCheck mempty
+
+-- | Interpreter mutable state.
 data EvalState b i
   = EvalState
   { _esCaps :: !(CapState QualifiedName PactValue)
-  , _esStack :: ![StackFrame]
+  -- ^ The current set of granted and installed
+  -- capabilities
+  , _esStack :: ![StackFrame i]
+  -- ^ The runtime callstack, as a structure
   , _esEvents :: ![PactEvent PactValue]
+  -- ^ The list of emitted pact events, if any
   , _esLoaded :: !(Loaded b i)
+  -- ^ The runtime symbol table and module environment
   , _esDefPactExec :: !(Maybe DefPactExec)
+  -- ^ The current defpact execution state, if any
   , _esGasLog :: !(Maybe [GasLogEntry b])
+  -- ^ The current gas log
+  , _esCheckRecursion :: NonEmpty RecursionCheck
     -- ^ Sequence of gas expendature events.
   } deriving (Show, Generic)
 
 instance (NFData b, NFData i) => NFData (EvalState b i)
 
 instance Default (EvalState b i) where
-  def = EvalState def [] [] mempty Nothing Nothing
+  def = EvalState def [] [] mempty Nothing Nothing (RecursionCheck mempty :| [])
 
 makeClassy ''EvalState
 

pact/Pact/Core/Environment/Utils.hs

@@ -16,6 +16,7 @@ module Pact.Core.Environment.Utils
  , getModuleData
  , getModule
  , getModuleMember
+ , getModuleMemberWithHash
  , lookupModule
  , lookupModuleData
  , throwExecutionError
@@ -25,11 +26,14 @@ module Pact.Core.Environment.Utils
  , getAllStackCaps
  , checkSigCaps
  , allModuleExports
+ , liftDbFunction
  ) where
 
 import Control.Lens
 import Control.Applicative((<|>))
 import Control.Monad.Except
+import Control.Exception
+import Control.Monad.IO.Class(MonadIO(..))
 import Data.Default
 import Data.Maybe(mapMaybe)
 import qualified Data.Map.Strict as M
@@ -84,10 +88,22 @@ allModuleExports = \case
         allNewDeps = M.fromList $ toFqDep (_ifName iface) (_ifHash iface) <$> defs
     in allNewDeps <> deps
 
-throwExecutionError :: (MonadEval b i m) => i -> EvalError -> m a
-throwExecutionError i e = throwError (PEExecutionError e i)
-
-throwExecutionError' :: (MonadEval b i m) => EvalError -> m a
+liftDbFunction
+  :: (MonadEvalState b i m, MonadError (PactError i) m, MonadIO m)
+  => i
+  -> IO a
+  -> m a
+liftDbFunction info action = do
+  liftIO (try action) >>= \case
+    Left dbopErr -> throwExecutionError info (DbOpFailure dbopErr)
+    Right e -> pure e
+
+throwExecutionError :: (MonadEvalState b i m, MonadError (PactError i) m) => i -> EvalError -> m a
+throwExecutionError i e = do
+  st <- useEvalState esStack
+  throwError (PEExecutionError e st i)
+
+throwExecutionError' :: (MonadEvalState b i m, MonadError (PactError i) m, Default i) => EvalError -> m a
 throwExecutionError' = throwExecutionError def
 
 -- | lookupModuleData for only modules
@@ -152,6 +168,16 @@ getModuleMember info pdb (QualifiedName qn mn) = do
       throwExecutionError info (NameNotInScope fqn)
 
 
+getModuleMemberWithHash :: (MonadEval b i m) => i -> PactDb b i -> QualifiedName -> m (EvalDef b i, ModuleHash)
+getModuleMemberWithHash info pdb (QualifiedName qn mn) = do
+  md <- getModule info pdb mn
+  case findDefInModule qn md of
+    Just d -> pure (d, _mHash md)
+    Nothing -> do
+      let fqn = FullyQualifiedName mn qn (_mHash md)
+      throwExecutionError info (NameNotInScope fqn)
+
+
 mangleNamespace :: (MonadEvalState b i m) => ModuleName -> m ModuleName
 mangleNamespace mn@(ModuleName mnraw ns) =
   useEvalState (esLoaded . loNamespace) >>= \case