merge

pact-core.cabal

@@ -105,6 +105,7 @@ library
     Pact.Core.Capabilities
     Pact.Core.ModRefs
     Pact.Core.Interpreter
+    Pact.Core.Environment
 
      -- Syntax modules
     Pact.Core.Syntax.ParseTree

pact-core/Pact/Core/Builtin.hs

@@ -223,6 +223,23 @@ data RawBuiltin
   | RawYield
   | RawResume
   | RawBind
+  -- Database functions
+  | RawCreateTable
+  | RawDescribeKeyset
+  | RawDescribeModule
+  | RawDescribeTable
+  | RawFoldDb
+  | RawInsert
+  | RawKeyLog
+  | RawKeys
+  | RawRead
+  | RawSelect
+  | RawUpdate
+  | RawWithDefaultRead
+  | RawWithRead
+  | RawWrite
+  -- | RawTxIds
+  -- | RawTxLog
   deriving (Eq, Show, Ord, Bounded, Enum)
 
 instance HasObjectOps RawBuiltin where
@@ -306,6 +323,20 @@ rawBuiltinToText = \case
   RawYield -> "yield"
   RawResume -> "resume"
   RawBind -> "bind"
+  RawCreateTable -> "create-table"
+  RawDescribeKeyset -> "describe-keyset"
+  RawDescribeModule -> "describe-module"
+  RawDescribeTable -> "describe-table"
+  RawFoldDb -> "fold-db"
+  RawInsert -> "insert"
+  RawKeyLog -> "keylog"
+  RawKeys -> "keys"
+  RawRead -> "read"
+  RawSelect -> "select"
+  RawUpdate -> "update"
+  RawWithDefaultRead -> "with-default-read"
+  RawWithRead -> "with-read"
+  RawWrite -> "write"
 
 instance IsBuiltin RawBuiltin where
   builtinName = NativeName . rawBuiltinToText
@@ -386,6 +417,20 @@ instance IsBuiltin RawBuiltin where
     RawYield -> 1
     RawResume -> 1
     RawBind -> 2
+    RawCreateTable -> 1
+    RawDescribeKeyset -> 1
+    RawDescribeModule -> 1
+    RawDescribeTable -> 1
+    RawFoldDb -> 3
+    RawInsert -> 3
+    RawKeyLog -> 3
+    RawKeys -> 1
+    RawRead -> 2
+    RawSelect -> 2
+    RawUpdate -> 3
+    RawWithDefaultRead -> 4
+    RawWithRead -> 3
+    RawWrite -> 3
 
 rawBuiltinNames :: [Text]
 rawBuiltinNames = fmap rawBuiltinToText [minBound .. maxBound]

pact-core/Pact/Core/Capabilities.hs

@@ -1,15 +1,20 @@
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE InstanceSigs #-}
 
 
 module Pact.Core.Capabilities
  ( DefCapMeta(..)
  , DefManagedMeta(..)
  , CapForm(..)
  , capFormName
+ , CapToken(..)
+ , CapSlot(..)
+ , FQCapToken
  ) where
 
 import Control.Lens
-
+import Pact.Core.Names
+import Pact.Core.PactValue
 import Pact.Core.Pretty
 
 data DefManagedMeta name
@@ -56,3 +61,19 @@ instance (Pretty name, Pretty e) => Pretty (CapForm name e) where
     CreateUserGuard name es ->
       parens ("create-user-guard" <+> parens (pretty name <+> hsep (pretty <$> es)))
 
+-- | An acquired capability token
+-- with the reference
+data CapToken name
+  = CapToken
+  { _ctName :: name
+  , _ctArgs :: [PactValue]
+  } deriving (Show, Eq, Ord)
+
+--
+data CapSlot name
+ = CapSlot
+ { _csCap :: CapToken name
+ , _csComposed :: [CapToken name]
+ } deriving (Show, Eq)
+
+type FQCapToken = CapToken FullyQualifiedName

pact-core/Pact/Core/Compile.hs

@@ -30,6 +30,7 @@ import Pact.Core.Pretty
 import Pact.Core.Type
 import Pact.Core.IR.Term
 import Pact.Core.Interpreter
+import Pact.Core.Guards
 
 
 -- import qualified Pact.Core.Syntax.LexUtils as Lisp
@@ -62,24 +63,54 @@ data CompileValue b
   deriving Show
 
 
-
 compileProgram
   :: (HasCompileEnv b s m)
   => ByteString
   -> PactDb b SpanInfo
-  -> Interpreter b s m
+  -> Interpreter b m
   -> m [CompileValue b]
 compileProgram source pdb interp = do
   lexed <- liftEither (Lisp.lexer source)
   debugPrint DebugLexer lexed
   parsed <- liftEither (Lisp.parseProgram lexed)
   lo <- use loaded
-  traverse (runDesugarTopLevel Proxy pdb lo >=> interpretTopLevel pdb interp) parsed
+  traverse (go lo) parsed
+  where
+  go lo =
+    evalModuleGovernance pdb interp
+    >=> runDesugarTopLevel Proxy pdb lo
+    >=> interpretTopLevel pdb interp
+
+evalModuleGovernance
+  :: (HasCompileEnv b s m)
+  => PactDb b SpanInfo
+  -> Interpreter b m
+  -> Lisp.TopLevel SpanInfo
+  -> m (Lisp.TopLevel SpanInfo)
+evalModuleGovernance pdb interp = \case
+  tl@(Lisp.TLModule m) -> liftIO (readModule pdb (Lisp._mName m)) >>= \case
+    Just (ModuleData md _) ->
+      case _mGovernance md of
+        KeyGov _ksn -> error "TODO: implement enforcing keyset names"
+        CapGov (Name n nk) -> case nk of
+          NTopLevel mn mh ->
+            use (loaded . loAllLoaded . at (FullyQualifiedName mn n mh)) >>= \case
+              Just (DCap d) ->
+                _interpret interp (_dcapTerm d) >>= \case
+                  IPV{} -> pure tl
+                  _ -> error "governance failure"
+              -- Todo: Definitely fixable with a GADT
+              _ -> error "invalid governance: not a defcap"
+          _ -> error "invariant failure: governance is not a fully qualified name"
+    Just (InterfaceData iface _) ->
+      throwError (PEExecutionError (CannotUpgradeInterface (_ifName iface)) (_ifInfo iface))
+    Nothing -> pure tl
+  a -> pure a
 
 interpretTopLevel
   :: (HasCompileEnv b s m)
   => PactDb b SpanInfo
-  -> Interpreter b s m
+  -> Interpreter b m
   -> DesugarOutput b SpanInfo (TopLevel Name Type b SpanInfo)
   -> m (CompileValue b)
 interpretTopLevel pdb interp (DesugarOutput ds lo0 deps) = do

pact-core/Pact/Core/Environment.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE InstanceSigs #-}
+
+
+module Pact.Core.Environment
+ ( EvalEnv(..)
+ , eeMsgSigs
+ , eePactDb
+ , eeHash
+--  , eeWarning
+ , eeMsgBody
+ , PactState(..)
+ , psLoaded
+ ) where
+
+import Control.Lens
+-- import Data.Text(Text)
+import Data.Set(Set)
+import Data.Map.Strict(Map)
+-- import Data.IORef(IORef)
+
+import Pact.Core.Persistence
+import Pact.Core.Capabilities
+-- import Pact.Core.Gas
+import Pact.Core.Guards
+import Pact.Core.PactValue
+import Pact.Core.Hash
+-- import Pact.Core.Names
+
+
+-- From pact
+-- | All of the types included in our evaluation environment.
+data EvalEnv b i
+  = EvalEnv
+  { _eeMsgSigs :: Map PublicKeyText (Set FQCapToken)
+  , _eePactDb :: PactDb b i
+  , _eeMsgBody :: EnvData PactValue
+  -- Todo: `PactWarning`
+  -- , _eeWarning :: IORef (Set Text)
+  , _eeHash :: Hash
+  --   _cekGas :: IORef Gas
+  -- , _cekEvalLog :: IORef (Maybe [(Text, Gas)])
+  -- , _ckeData :: EnvData PactValue
+  }
+
+makeLenses ''EvalEnv
+
+newtype PactState b i
+  = PactState
+  { _psLoaded :: Loaded b i
+  }
+
+makeLenses ''PactState

pact-core/Pact/Core/Errors.hs

@@ -297,6 +297,8 @@ data EvalError
   | NoYieldInPactExec
   | ContinuePactInvalidContext Integer Integer Integer
   | MultipleOrNestedPactExecFound
+  -- ^ No such keyset
+  | CannotUpgradeInterface ModuleName
   deriving Show
 
 instance Pretty EvalError where
@@ -334,7 +336,7 @@ instance Pretty EvalError where
     ContinuePactInvalidContext userStep currStep maxStep ->
       Pretty.hsep ["Continue pact step with invalid context: user: ", pretty userStep, ", current: ", pretty currStep, ", max: ", pretty maxStep]
     MultipleOrNestedPactExecFound -> "Multiple or nested pact exec found"
-    _ -> error "todo: render"
+    err -> error ("todo: render" ++ show err)