WIP gasM

kadena-io · May 15, 2024 · 3d8ea62 · 3d8ea62
1 parent 2d05576
commit 3d8ea62
Show file tree

Hide file tree

Showing 12 changed files with 454 additions and 350 deletions.
diff --git a/pact-tng.cabal b/pact-tng.cabal
@@ -97,6 +97,7 @@ common pact-common
     FlexibleInstances
     NumericUnderscores
     TypeOperators
+    PartialTypeSignatures
 
 -- internal crypto lirbary
 library pact-crypto
@@ -156,6 +157,8 @@ library
     Pact.Core.Info
     Pact.Core.Errors
     Pact.Core.Persistence
+    Pact.Core.Persistence.Types
+    Pact.Core.Persistence.Utils
     Pact.Core.Persistence.SQLite
     Pact.Core.Persistence.MockPersistence
     Pact.Core.PactValue
@@ -278,7 +281,7 @@ benchmark bench
     , mtl
     , pact-tng
     , text
-  ghc-options: -WAll -threaded -rtsopts "-with-rtsopts=-N" 
+  ghc-options: -WAll -threaded -rtsopts "-with-rtsopts=-N"
   hs-source-dirs: bench
   default-language: Haskell2010
 

diff --git a/pact/Pact/Core/Environment/Types.hs b/pact/Pact/Core/Environment/Types.hs
@@ -69,7 +69,7 @@ import Control.Monad.Catch as Exceptions
 import qualified Data.Text as T
 import qualified Data.Map.Strict as M
 
-import Pact.Core.Persistence
+import Pact.Core.Persistence.Types
 import Pact.Core.Pretty
 import Pact.Core.Capabilities
 import Pact.Core.Guards
@@ -241,9 +241,9 @@ defaultEvalEnv pdb m = do
 
 type Bytes = Word64
 
-newtype SizeOfByteLimit 
+newtype SizeOfByteLimit
   = SizeOfByteLimit Bytes
   deriving Show
 
 instance Pretty SizeOfByteLimit where
-  pretty = pretty . show
+  pretty = pretty . show
diff --git a/pact/Pact/Core/Environment/Utils.hs b/pact/Pact/Core/Environment/Utils.hs
@@ -36,7 +36,7 @@ import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 
 import Pact.Core.Names
-import Pact.Core.Persistence
+import Pact.Core.Persistence.Types
 import Pact.Core.IR.Term
 import Pact.Core.Errors
 import Pact.Core.Environment.Types

diff --git a/pact/Pact/Core/Gas.hs b/pact/Pact/Core/Gas.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
 
 module Pact.Core.Gas
  ( MilliGas(..)
@@ -35,10 +36,16 @@ module Pact.Core.Gas
  , GasObjectSize(..)
  , ComparisonType(..)
  , SearchType(..)
+ , GasMEnv(..)
+ , GasM(..)
+ , runGasM
  ) where
 
 import Control.Lens
 import Control.DeepSeq
+import Control.Monad.Reader
+import Control.Monad.Except
+import Data.IORef
 import Data.Decimal(Decimal)
 import Data.Word(Word64)
 import Data.Monoid(Sum(..))
@@ -121,7 +128,9 @@ data ZKGroup
   -- ^ Group one, that is Fq in Pairing
   | ZKG2
   -- ^ Group two, that is, Fq2 Pairing
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic)
+
+instance NFData ZKGroup
 
 data ZKArg
   = PointAdd !ZKGroup
@@ -262,3 +271,26 @@ gasToMilliGas (Gas n) = MilliGas (n * millisPerGas)
 milliGasToGas :: MilliGas -> Gas
 milliGasToGas (MilliGas n) = Gas (n `quot` millisPerGas)
 {-# INLINE milliGasToGas #-}
+
+data GasMEnv
+  = GasMEnv
+  { _gasMRef :: IORef MilliGas
+  , _gasMLimit :: MilliGasLimit
+  }
+
+newtype GasM e a
+  = GasM (ReaderT GasMEnv (ExceptT e IO) a)
+  deriving
+  ( Functor
+  , Applicative
+  , Monad
+  , MonadReader GasMEnv
+  , MonadError e
+  , MonadIO) via (ReaderT GasMEnv (ExceptT e IO))
+
+runGasM
+  :: GasMEnv
+  -> GasM e a
+  -> IO (Either e a)
+runGasM env (GasM m) =
+  runExceptT $ runReaderT m env
diff --git a/pact/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact/Pact/Core/IR/Eval/Runtime/Utils.hs
@@ -247,7 +247,8 @@ readOnlyEnv e
               PactDb
              { _pdbPurity = PReadOnly
              , _pdbRead = _pdbRead pdb
-             , _pdbWrite = \_ _ _ _ _ -> dbOpDisallowed2
+             , _pdbWrite = \info _wt _d _k _v ->
+                throwError (PEExecutionError (DbOpFailure OpDisallowed) info)
              , _pdbKeys = \_ -> dbOpDisallowed
              , _pdbCreateUserTable = \_ -> dbOpDisallowed
              , _pdbBeginTx = \_ -> dbOpDisallowed