wip

pact-core.cabal

@@ -111,6 +111,7 @@ library
     Pact.Core.ChainData
     Pact.Core.Environment
     Pact.Core.Environment.Utils
+    Pact.Core.Environment.State
     Pact.Core.Environment.Types
     Pact.Core.StableEncoding
     Pact.Core.Principal

pact-core/Pact/Core/Environment/State.hs

@@ -0,0 +1,30 @@
+-- |
+
+module Pact.Core.Environment.State
+  ( EvalState(..)
+  , MonadEvalState
+  , HasEvalState
+  ) where
+
+-- | Aspects of the evaluation environment that are updated during the evaluation
+-- of a single pact transaction.
+data EvalState b i
+  = EvalState
+  { _esCaps :: CapState QualifiedName PactValue
+  , _esStack :: [StackFrame]
+  , _esEvents :: [PactEvent PactValue]
+  , _esLoaded :: Loaded b i
+  , _esDefPactExec :: Maybe DefPactExec
+  , _esTxId :: Maybe TxId
+  } deriving Show
+
+instance Default (EvalState b i) where
+  def = EvalState def [] [] mempty Nothing Nothing
+
+makeClassy ''EvalState
+
+-- | Any monad that can read, put, or modify the eval state.
+class Monad m => MonadEvalState b i m | m -> b, m -> i where
+  getEvalState :: m (EvalState b i)
+  putEvalState :: EvalState b i -> m ()
+  modifyEvalState :: (EvalState b i -> EvalState b i) -> m ()

pact-core/Pact/Core/Environment/Types.hs

@@ -35,7 +35,6 @@ module Pact.Core.Environment.Types
  , cdBlockTime, cdPrevBlockHash
  , cdSender, cdGasLimit, cdGasPrice
  , EvalState(..)
- , HasEvalState(..)
  , StackFrame(..)
  , StackFunctionType(..)
  , flagRep
@@ -70,6 +69,7 @@ import Pact.Core.ChainData
 import Pact.Core.Errors
 import Pact.Core.Gas
 import Pact.Core.Namespace
+import Pact.Core.Environment.State (EvalState(..), MonadEvalState, HasEvalState)
 
 -- | Execution flags specify behavior of the runtime environment,
 -- with an orientation towards some alteration of a default behavior.
@@ -133,6 +133,9 @@ newtype PactState b i
 
 makeLenses ''PactState
 
+instance HasLoaded (EvalState b i) b i where
+  loaded = esLoaded
+
 data StackFunctionType
   = SFDefun
   | SFDefcap
@@ -146,33 +149,10 @@ data StackFrame
   , _sfFnType :: StackFunctionType }
   deriving Show
 
-data EvalState b i
-  = EvalState
-  { _esCaps :: CapState QualifiedName PactValue
-  , _esStack :: [StackFrame]
-  , _esEvents :: [PactEvent PactValue]
-  , _esLoaded :: Loaded b i
-  , _esDefPactExec :: Maybe DefPactExec
-  , _esTxId :: Maybe TxId
-  } deriving Show
-
-instance Default (EvalState b i) where
-  def = EvalState def [] [] mempty Nothing Nothing
-
-makeClassy ''EvalState
-
-instance HasLoaded (EvalState b i) b i where
-  loaded = esLoaded
 
 class (Monad m) => MonadEvalEnv b i m | m -> b, m -> i where
   readEnv :: m (EvalEnv b i)
 
--- | Our monad mirroring `EvalState` for our evaluation state
-class Monad m => MonadEvalState b i m | m -> b, m -> i where
-  getEvalState :: m (EvalState b i)
-  putEvalState :: EvalState b i -> m ()
-  modifyEvalState :: (EvalState b i -> EvalState b i) -> m ()
-
 -- Our General constraint for evaluation and general analysis
 type MonadEval b i m =
   ( MonadEvalEnv b i m

pact-core/Pact/Core/Errors.hs

@@ -14,6 +14,7 @@ module Pact.Core.Errors
  , ArgTypeError(..)
  , peInfo
  , liftDbFunction
+ , dbOpDisallowed
  ) where
 
 import Control.Lens hiding (ix)
@@ -22,14 +23,14 @@ import Control.Monad.IO.Class(MonadIO(..))
 import Control.Exception
 import Data.Text(Text)
 import Data.Dynamic (Typeable)
+import Data.Word(Word64)
 
 import Pact.Core.Type
 import Pact.Core.Names
 import Pact.Core.Guards
 import Pact.Core.Info
 import Pact.Core.Pretty(Pretty(..))
 import Pact.Core.Hash
-import Pact.Core.Persistence
 import Pact.Core.DefPacts.Types
 
 import qualified Pact.Core.Pretty as Pretty
@@ -498,3 +499,19 @@ liftDbFunction
 liftDbFunction info action = do
   e <- liftIO $ catch (Right <$> action) (pure . Left . DbOpFailure)
   either (throwError . (`PEExecutionError` info)) pure e
+
+
+data DbOpException
+  = WriteException
+  | NoSuchTable TableName
+  | TableAlreadyExists TableName
+  | TxAlreadyBegun Word64
+  | NoTxToCommit
+  | NoTxLog TableName Word64
+  | OpDisallowed
+  deriving (Show, Eq, Typeable)
+
+dbOpDisallowed :: IO a
+dbOpDisallowed = throwIO OpDisallowed
+
+instance Exception DbOpException

pact-core/Pact/Core/Persistence.hs

@@ -28,23 +28,24 @@ module Pact.Core.Persistence
  , readDefPacts, writeDefPacts
  , readNamespace, writeNamespace
  , GuardTableOp(..)
- , DbOpException(..)
  , TxId(..)
  , TxLog(..)
- , dbOpDisallowed
  , toUserTable
  , FQKS
  ) where
 
 import Control.Lens
+import Control.Monad.IO.Class (MonadIO)
 import Control.Exception(throwIO, Exception)
 import Control.Applicative((<|>))
 import Data.Default
 import Data.IORef (IORef)
 import Data.Map.Strict(Map)
 import Data.Text(Text)
 import Data.Word(Word64)
+import Pact.Core.Errors (DbOpException(WriteException, NoSuchTableName, TableAlreadyExists, TxAlreadyBegun, NoTxToCommit, NoTxLog, OpDisallowed), dbOpDisallowed)
 
+import Pact.Core.Environment.State (MonadEvalState)
 import Pact.Core.Type
 import Pact.Core.Names
 import Pact.Core.IR.Term
@@ -155,7 +156,7 @@ data PactDb b i
   , _pdbWrite :: forall k v. WriteType -> Domain k v b i -> k -> v -> IO ()
   , _pdbKeys :: forall k v. Domain k v b i -> IO [k]
   , _pdbCreateUserTable :: TableName -> IO ()
-  , _pdbBeginTx :: ExecutionMode -> IO (Maybe TxId)
+  , _pdbBeginTx :: forall b i m. (MonadEvalState b i m, MonadIO m) => ExecutionMode -> m (Maybe TxId)
   , _pdbCommitTx :: IO ()
   , _pdbRollbackTx :: IO ()
   , _pdbTxIds :: TableName -> TxId -> IO [TxId]
@@ -165,6 +166,7 @@ data PactDb b i
     -- TODO: This field is morally part of
   }
 
+
 makeClassy ''PactDb
 
 -- Potentially new Pactdb abstraction
@@ -194,21 +196,6 @@ readNamespace pdb = _pdbRead pdb DNamespaces
 writeNamespace :: PactDb b i -> WriteType -> NamespaceName -> Namespace -> IO ()
 writeNamespace pdb wt = _pdbWrite pdb wt DNamespaces
 
-data DbOpException
-  = WriteException
-  | NoSuchTable TableName
-  | TableAlreadyExists TableName
-  | TxAlreadyBegun TxId
-  | NoTxToCommit
-  | NoTxLog TableName TxId
-  | OpDisallowed
-  deriving (Show, Eq, Typeable)
-
-dbOpDisallowed :: IO a
-dbOpDisallowed = throwIO OpDisallowed
-
-instance Exception DbOpException
-
 data GuardTableOp
   = GtRead
   | GtSelect

pact-core/Pact/Core/Persistence/SQLite.hs

@@ -57,7 +57,7 @@ initializePactDb serial db = do
     , _pdbWrite = write' serial db
     , _pdbKeys = readKeys db
     , _pdbCreateUserTable = createUserTable db
-    , _pdbBeginTx = beginTx txId db
+    , _pdbBeginTx = a -- beginTx txId db
     , _pdbCommitTx = commitTx txId db
     , _pdbRollbackTx = rollbackTx db
     , _pdbTxIds = error "no txids"