Fix gasSerializePactValue signature and update _pdbCreateUserTable

gasmodel/Pact/Core/GasModel/Utils.hs

@@ -236,7 +236,7 @@ gmLoaded = Loaded
 prepopulateDb :: PactDb CoreBuiltin i -> IO ()
 prepopulateDb pdb = do
   _ <- _pdbBeginTx pdb Transactional
-  _pdbCreateUserTable pdb gasModelTable
+  _pdbCreateUserTable pdb def gasModelTable
   _pdbWrite pdb expectNoGas Write (DUserTables gasModelTable) gmTableK1 gmTableV1
   _pdbWrite pdb expectNoGas Write (DUserTables gasModelTable) gmTableK1 gmTableV1
   _pdbWrite pdb expectNoGas Write DNamespaces gmNamespaceName gmNamespace

pact/Pact/Core/Compile.hs

@@ -216,7 +216,7 @@ evalTopLevel bEnv tlFinal deps = do
           mdata = ModuleData m deps'
       mSize <- sizeOf SizeOfV0 m
       chargeGasArgs (_mInfo m) (GModuleMemory mSize)
-      _ <- liftDbFunction2 (_mInfo m) $ writeModule pdb Write (view mName m) mdata
+      writeModule (_mInfo m) pdb Write (view mName m) mdata
       let fqDeps = toFqDep (_mName m) (_mHash m) <$> _mDefs m
           newLoaded = M.fromList fqDeps
           newTopLevel = M.fromList $ (\(fqn, d) -> (_fqName fqn, (fqn, defKind (_mName m) d))) <$> fqDeps
@@ -232,7 +232,7 @@ evalTopLevel bEnv tlFinal deps = do
           mdata = InterfaceData iface deps'
       ifaceSize <- sizeOf SizeOfV0 iface
       chargeGasArgs (_ifInfo iface) (GModuleMemory ifaceSize)
-      _ <- liftDbFunction2 (_ifInfo iface) $ writeModule pdb Write (view ifName iface) mdata
+      writeModule (_ifInfo iface) pdb Write (view ifName iface) mdata
       let fqDeps = toFqDep (_ifName iface) (_ifHash iface)
                   <$> mapMaybe ifDefToDef (_ifDefns iface)
           newLoaded = M.fromList fqDeps

pact/Pact/Core/IR/Eval/CEK.hs

@@ -1358,7 +1358,7 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do
           let rdata = RowData rv
           rvSize <- sizeOf SizeOfV2 rv
           chargeGasArgs info (GWrite rvSize)
-          _ <- liftDbFunction2 info $ _pdbWrite pdb serializationGasser wt (tvToDomain tv) rk rdata
+          _ <- liftGasM $ _pdbWrite pdb info wt (tvToDomain tv) rk rdata
           returnCEKValue cont handler (VString "Write succeeded")
         else returnCEK cont handler (VError "object does not match schema" info)
       PreFoldDbC tv queryClo appClo -> do
@@ -1405,7 +1405,7 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do
             , (Field "key", PString key)
             , (Field "value", PObject rdata)]
       CreateTableC (TableValue tn _ _) -> do
-        liftDbFunction info (_pdbCreateUserTable pdb tn)
+        liftGasM (_pdbCreateUserTable pdb info tn)
         returnCEKValue cont handler (VString "TableCreated")
       EmitEventC ct@(CapToken fqn _) ->
         lookupFqName (_ctName ct) >>= \case
@@ -1422,15 +1422,15 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do
       DefineKeysetC ksn newKs -> do
         newKsSize <- sizeOf SizeOfV2 newKs
         chargeGasArgs info (GWrite newKsSize)
-        liftDbFunction2 info $ writeKeySet pdb Write ksn newKs
+        _ <- writeKeySet info pdb Write ksn newKs
         returnCEKValue cont handler (VString "Keyset write success")
       DefineNamespaceC ns -> case v of
         PBool allow ->
           if allow then do
             let nsn = _nsName ns
             nsSize <- sizeOf SizeOfV2 ns
             chargeGasArgs info (GWrite nsSize)
-            liftDbFunction2 info $ _pdbWrite pdb serializationGasser Write DNamespaces nsn ns
+            liftGasM $ _pdbWrite pdb info Write DNamespaces nsn ns
             returnCEKValue cont handler $ VString $ "Namespace defined: " <> (_namespaceName nsn)
           else throwExecutionError info $ DefineNamespaceError "Namespace definition not permitted"
         _ ->
@@ -1543,7 +1543,7 @@ applyContToValue (DefPactStepC env cont) handler v =
           done = (not (_psRollback ps) && isLastStep) || _psRollback ps
         when (nestedPactsNotAdvanced pe ps) $
           throwExecutionError def (NestedDefpactsNotAdvanced (_peDefPactId pe))
-        liftDbFunction2 def $ writeDefPacts pdb Write (_psDefPactId ps)
+        writeDefPacts def pdb Write (_psDefPactId ps) -- TODO: def used because we have no `info`.
             (if done then Nothing else Just pe)
         emitXChainEvents (_psResume ps) pe
         returnCEKValue cont handler v

pact/Pact/Core/IR/Eval/CoreBuiltin.hs

@@ -1108,7 +1108,7 @@ defineKeySet' info cont handler env ksname newKs  = do
       let writeKs = do
             newKsSize <- sizeOf SizeOfV0 newKs
             chargeGasArgs info (GWrite newKsSize)
-            liftDbFunction2 info $ writeKeySet pdb Write ksn newKs
+            writeKeySet info pdb Write ksn newKs
             returnCEKValue cont handler (VString "Keyset write success")
       liftDbFunction info (readKeySet pdb ksn) >>= \case
         Just oldKs -> do
@@ -1643,7 +1643,7 @@ coreDefineNamespace info b cont handler env = \case
         SimpleNamespacePolicy -> do
           nsSize <- sizeOf SizeOfV0 ns
           chargeGasArgs info (GWrite nsSize)
-          liftDbFunction2 info $ _pdbWrite pdb serializationGasser Write DNamespaces nsn ns
+          liftGasM $ _pdbWrite pdb info Write DNamespaces nsn ns
           returnCEKValue cont handler $ VString $ "Namespace defined: " <> n
         SmartNamespacePolicy _ fun -> getModuleMember info pdb fun >>= \case
           Dfun d -> do

pact/Pact/Core/IR/Eval/Runtime/Utils.hs

@@ -250,7 +250,7 @@ readOnlyEnv e
              , _pdbWrite = \info _wt _d _k _v ->
                 throwError (PEExecutionError (DbOpFailure OpDisallowed) info)
              , _pdbKeys = \_ -> dbOpDisallowed
-             , _pdbCreateUserTable = \_ -> dbOpDisallowed
+             , _pdbCreateUserTable = \_ _ -> dbOpDisallowed
              , _pdbBeginTx = \_ -> dbOpDisallowed
              , _pdbCommitTx = dbOpDisallowed
              , _pdbRollbackTx = dbOpDisallowed
@@ -269,7 +269,7 @@ sysOnlyEnv e
          , _pdbRead = read'
          , _pdbWrite = \_ _ _ _ _ -> dbOpDisallowed
          , _pdbKeys = const dbOpDisallowed
-         , _pdbCreateUserTable = \_ -> dbOpDisallowed
+         , _pdbCreateUserTable = \_ _ -> dbOpDisallowed
          , _pdbBeginTx = const dbOpDisallowed
          , _pdbCommitTx = dbOpDisallowed
          , _pdbRollbackTx = dbOpDisallowed

pact/Pact/Core/Persistence/MockPersistence.hs

@@ -17,7 +17,6 @@ import Data.IORef
 import qualified Data.Map.Strict as Map
 import qualified Data.Map.Strict as M
 import Data.ByteString (ByteString)
-import Data.IORef
 
 
 import Pact.Core.Guards
@@ -31,6 +30,8 @@ import Pact.Core.Errors
 
 import qualified Pact.Core.Errors as Errors
 import qualified Pact.Core.Persistence as Persistence
+import Pact.Core.PactValue
+import Pact.Core.Literal
 
 
 type TxLogQueue = IORef (Map TxId [TxLog ByteString])
@@ -50,7 +51,7 @@ mockPactDb serial = do
     , _pdbRead = read' refKs refMod refNS refUsrTbl refPacts
     , _pdbWrite = write refKs refMod refNS refUsrTbl refTxId refTxLog refPacts
     , _pdbKeys = keys refKs refMod refNS refUsrTbl refPacts
-    , _pdbCreateUserTable = createUsrTable refUsrTbl refTxId refTxLog
+    , _pdbCreateUserTable = \info tn -> createUsrTable info refUsrTbl refTxId refTxLog tn
     , _pdbBeginTx = beginTx refRb refTxId refTxLog refMod refKs refUsrTbl
     , _pdbCommitTx = commitTx refRb refTxId refTxLog refMod refKs refUsrTbl
     , _pdbRollbackTx = rollbackTx refRb refTxLog refMod refKs refUsrTbl
@@ -142,19 +143,26 @@ mockPactDb serial = do
       pure (M.keys r)
 
   createUsrTable
-    :: IORef (Map TableName (Map RowKey RowData))
+    :: i
+    -> IORef (Map TableName (Map RowKey RowData))
     -> IORef TxId
     -> TxLogQueue
     -> TableName
-    -> IO ()
-  createUsrTable refUsrTbl _refTxId _refTxLog tbl = do
-    ref <- readIORef refUsrTbl
+    -> GasM (PactError i) ()
+  createUsrTable info refUsrTbl _refTxId _refTxLog tbl = do
+    let rd = RowData $ Map.singleton (Field "utModule")
+          (PObject $ Map.fromList
+            [ (Field "namespace", maybe (PLiteral LUnit) (PString . _namespaceName) (_mnNamespace (_tableModuleName tbl)))
+            , (Field "name", PString (_tableName tbl))
+            ])
+    _rdEnc <- _encodeRowData serial info rd
+    ref <- liftIO $ readIORef refUsrTbl
     case M.lookup tbl ref of
       Nothing -> do
         -- TODO: Do we need a TxLog when a usertable is created?
-        modifyIORef refUsrTbl (M.insert tbl mempty)
+        liftIO $ modifyIORef refUsrTbl (M.insert tbl mempty)
         pure ()
-      Just _ -> throwIO (Errors.TableAlreadyExists tbl)
+      Just _ -> liftIO $ throwIO (Errors.TableAlreadyExists tbl)
 
   read'
     :: forall k v

pact/Pact/Core/Persistence/SQLite.hs

@@ -21,6 +21,7 @@ import qualified Database.SQLite3.Direct as Direct
 import Data.ByteString (ByteString)
 import qualified Data.Map.Strict as Map
 
+import qualified Pact.Core.Errors as E
 import Pact.Core.Persistence
 import Pact.Core.Guards (renderKeySetName, parseAnyKeysetName)
 import Pact.Core.Names
@@ -88,7 +89,7 @@ initializePactDb serial db = do
     , _pdbRead = read' serial db
     , _pdbWrite = write' serial db txId txLog
     , _pdbKeys = readKeys db
-    , _pdbCreateUserTable = createUserTable serial db txLog
+    , _pdbCreateUserTable = \info tn -> createUserTable info serial db txLog tn
     , _pdbBeginTx = beginTx txId db txLog
     , _pdbCommitTx = commitTx txId db txLog
     , _pdbRollbackTx = rollbackTx db txLog
@@ -176,16 +177,16 @@ rollbackTx db txLog = do
   SQL.exec db "ROLLBACK TRANSACTION"
   writeIORef txLog []
 
-createUserTable :: PactSerialise b i -> SQL.Database -> IORef [TxLog ByteString] -> TableName -> IO ()
-createUserTable serial db txLog tbl = do
-  liftIO $ SQL.exec db stmt
+createUserTable :: i -> PactSerialise b i -> SQL.Database -> IORef [TxLog ByteString] -> TableName -> GasM (PactError i) ()
+createUserTable info serial db txLog tbl = do
   let
     rd = RowData $ Map.singleton (Field "utModule")
          (PObject $ Map.fromList
           [ (Field "namespace", maybe (PLiteral LUnit) (PString . _namespaceName) (_mnNamespace (_tableModuleName tbl)))
           , (Field "name", PString (_tableName tbl))
           ])
   rdEnc <- _encodeRowData serial info rd
+  liftIO $ SQL.exec db stmt
   liftIO $ modifyIORef' txLog (TxLog "SYS:usertables" (_tableName tbl) rdEnc :)
 
   where
@@ -197,9 +198,8 @@ createUserTable serial db txLog tbl = do
     tblName = "\"" <> toUserTable tbl <> "\""
 
 write'
-  :: forall k v b i m.
-     MonadIO m
-  => PactSerialise b i
+  :: forall k v b i
+  .  PactSerialise b i
   -> SQL.Database
   -> IORef TxId
   -> IORef [TxLog ByteString]

pact/Pact/Core/Persistence/Types.hs

@@ -183,7 +183,7 @@ data PactDb b i
   , _pdbRead :: forall k v. Domain k v b i -> k -> IO (Maybe v)
   , _pdbWrite :: forall k v. i -> WriteType -> Domain k v b i -> k -> v -> GasM (PactError i) ()
   , _pdbKeys :: forall k v. Domain k v b i -> IO [k]
-  , _pdbCreateUserTable :: TableName -> IO ()
+  , _pdbCreateUserTable :: i -> TableName -> GasM (PactError i) ()
   , _pdbBeginTx :: ExecutionMode -> IO (Maybe TxId)
   , _pdbCommitTx :: IO [TxLog ByteString]
   , _pdbRollbackTx :: IO ()

pact/Pact/Core/Persistence/Utils.hs

@@ -1,64 +1,50 @@
 module Pact.Core.Persistence.Utils where
 
-import Control.Applicative((<|>))
-import Control.Lens
 import Control.Exception(throwIO)
-import qualified Control.Monad.Catch as Exceptions
 import Control.Monad.Error.Class (MonadError, throwError)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Default
-import Data.Map.Strict(Map)
-import Control.DeepSeq
-import GHC.Generics
-import Data.Text(Text)
-import Data.Word(Word64)
-import Data.ByteString (ByteString)
-
-import Pact.Core.Type
+
 import Pact.Core.Names
-import Pact.Core.IR.Term
 import Pact.Core.Guards
-import Pact.Core.Hash
-import Pact.Core.PactValue
 import Pact.Core.DefPacts.Types
 import Pact.Core.Gas
 import Pact.Core.Namespace
 import Pact.Core.Errors
 import Pact.Core.Persistence.Types
 import Pact.Core.Environment
 
+
 -- Potentially new Pactdb abstraction
 -- That said: changes in `Purity` that restrict read/write
 -- have to be done for all read functions.
 readModule :: PactDb b i -> ModuleName -> IO (Maybe (ModuleData b i))
 readModule pdb = _pdbRead pdb DModules
 
 writeModule :: (MonadEval b i m) => i -> PactDb b i -> WriteType -> ModuleName -> ModuleData b i -> m ()
-writeModule info pdb wt mn md = do
-  gasRef <- viewEvalEnv eeGasRef
-  gasLimit <- viewEvalEnv (eeGasModel . gmGasLimit)
-  either throwError pure =<< liftIO (runGasM (GasMEnv gasRef gasLimit) (_pdbWrite pdb info wt DModules mn md))
+writeModule info pdb wt mn md =
+  liftGasM $ _pdbWrite pdb info wt DModules mn md
 
 readKeySet :: PactDb b i -> KeySetName -> IO (Maybe KeySet)
 readKeySet pdb = _pdbRead pdb DKeySets
 
-writeKeySet :: (MonadIO m, MonadError (PactError i) m, Default i, Exceptions.MonadCatch m) => PactDb b i -> WriteType -> KeySetName -> KeySet -> m ()
-writeKeySet pdb wt = undefined
-  -- _pdbWrite pdb failIfUsesGas wt DKeySets
+writeKeySet :: (MonadEval b i m) => i -> PactDb b i -> WriteType -> KeySetName -> KeySet -> m ()
+writeKeySet info pdb wt ksn ks = do
+  liftGasM $ _pdbWrite pdb info wt DKeySets ksn ks
 
 readDefPacts :: PactDb b i -> DefPactId -> IO (Maybe (Maybe DefPactExec))
 readDefPacts pdb = _pdbRead pdb DDefPacts
 
-writeDefPacts :: (MonadIO m, MonadError (PactError i) m, Default i, Exceptions.MonadCatch m) => PactDb b i -> WriteType -> DefPactId -> Maybe DefPactExec -> m ()
-writeDefPacts pdb wt = undefined
-  -- _pdbWrite pdb failIfUsesGas wt DDefPacts
+writeDefPacts :: (MonadEval b i m) => i -> PactDb b i -> WriteType -> DefPactId -> Maybe DefPactExec -> m ()
+writeDefPacts info pdb wt defpactId defpactExec =
+  liftGasM $ _pdbWrite pdb info wt DDefPacts defpactId defpactExec
 
 readNamespace :: PactDb b i -> NamespaceName -> IO (Maybe Namespace)
 readNamespace pdb = _pdbRead pdb DNamespaces
 
-writeNamespace :: (MonadIO m, MonadError (PactError i) m, Default i, Exceptions.MonadCatch m) => PactDb b i -> WriteType -> NamespaceName -> Namespace -> m ()
-writeNamespace pdb wt = undefined
-  -- _pdbWrite pdb failIfUsesGas wt DNamespaces
+writeNamespace :: (MonadEval b i m) => i -> PactDb b i -> WriteType -> NamespaceName -> Namespace -> m ()
+writeNamespace info pdb wt namespaceName namespace =
+  liftGasM $ _pdbWrite pdb info wt DNamespaces namespaceName namespace
 
 -- | For several db operations, we expect not to use gas. This
 --   function tests that assumption by failing if it is violated.
@@ -71,3 +57,10 @@ dbOpDisallowed = liftIO $ putStrLn "OpDisallowed" >> throwIO OpDisallowed
 
 dbOpDisallowed2 :: forall i m a. (MonadError (PactError i) m, MonadIO m, Default i) => m a
 dbOpDisallowed2 = liftIO (putStrLn "OpDisallowed") >> throwError (PEExecutionError (DbOpFailure OpDisallowed) def)
+
+-- | A utility function that lifts a `GasM` action into a `MonadEval` action.
+liftGasM :: MonadEval b i m => GasM (PactError i) a -> m a
+liftGasM action = do
+  gasRef <- viewEvalEnv eeGasRef
+  gasLimit <- viewEvalEnv (eeGasModel . gmGasLimit)
+  either throwError pure =<< liftIO (runGasM (GasMEnv gasRef gasLimit) action)

pact/Pact/Core/Serialise/CBOR_V1.hs

@@ -106,7 +106,7 @@ encodeRowData info rd@(RowData fields) = do
   traverse_ (gasSerializePactValue info) fields
   pure . toStrictByteString $ encode rd
 
-gasSerializePactValue :: i -> PactValue -> _
+gasSerializePactValue :: i -> PactValue -> GasM (PactError i) ()
 gasSerializePactValue info = \case
   PLiteral l -> gasSerializeLiteral l
   PList vs -> do