Add current eval env txid to the PactDb

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

@@ -151,10 +151,11 @@ data EvalState b i
   , _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
+  def = EvalState def [] [] mempty Nothing Nothing
 
 makeClassy ''EvalState
 

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

@@ -159,14 +159,14 @@ evalCEK cont handler env (Conditional c info) = case c of
     evalCEK (CondC env info (OrFrame te') cont) handler env te
   CIf cond e1 e2 ->
     evalCEK (CondC env info (IfFrame e1 e2) cont) handler env cond
-  CEnforce cond str ->
-    let env' = sysOnlyEnv env
-    in evalCEK (CondC env' info (EnforceFrame str) cont) handler env' cond
+  CEnforce cond str -> do
+    env' <- liftIO $ sysOnlyEnv env
+    evalCEK (CondC env' info (EnforceFrame str) cont) handler env' cond
   CEnforceOne str conds -> case conds of
     [] -> returnCEK cont handler (VError "enforce-one failure" info)
     x:xs -> do
       errState <- evalStateToErrorState <$> getEvalState
-      let env' = readOnlyEnv env
+      env' <- liftIO $ readOnlyEnv env
       let handler' = CEKEnforceOne env' info str xs cont errState handler
       let cont' = CondC env' info (EnforceOneFrame str xs) Mt
       evalCEK cont' handler' env' x
@@ -196,7 +196,7 @@ evalCEK cont handler env (ListLit ts _) = do
 evalCEK cont handler env (Try catchExpr rest _) = do
   errState <- evalStateToErrorState <$> getEvalState
   let handler' = CEKHandler env catchExpr cont errState handler
-  let env' = readOnlyEnv env
+  env' <- liftIO $ readOnlyEnv env
   evalCEK Mt handler' env' rest
 evalCEK cont handler env (ObjectLit o _) =
   case o of

pact-core/Pact/Core/IR/Eval/RawBuiltin.hs

@@ -766,7 +766,7 @@ runUserGuard info cont handler env (UserGuard fqn args) =
   lookupFqName fqn >>= \case
     Just (Dfun d) -> do
       when (length (_dfunArgs d) /= length args) $ throwExecutionError info CannotApplyPartialClosure
-      let env' = sysOnlyEnv env
+      env' <- liftIO $ sysOnlyEnv env
       clo <- mkDefunClosure d (_fqModule fqn) env'
       -- Todo: sys only here
       applyLam (C clo) (VPactValue <$> args) (UserGuardC cont) handler

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

@@ -7,6 +7,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Pact.Core.IR.Eval.Runtime.Utils
  ( mkBuiltinFn
@@ -39,6 +40,7 @@ module Pact.Core.IR.Eval.Runtime.Utils
 import Control.Lens
 import Control.Monad(when)
 import Control.Monad.Except(MonadError(..))
+import Data.IORef (newIORef)
 import Data.Map.Strict(Map)
 import Data.Text(Text)
 import Data.Set(Set)
@@ -219,44 +221,49 @@ asBool
 asBool _ _ (PLiteral (LString b)) = pure b
 asBool i b pv = argsError i b [VPactValue pv]
 
-readOnlyEnv :: CEKEnv b i m -> CEKEnv b i m
+readOnlyEnv :: CEKEnv b i m -> IO (CEKEnv b i m)
 readOnlyEnv e
-  | view (cePactDb . pdbPurity) e == PSysOnly = e
-  | otherwise =
-  let pdb = view cePactDb  e
-      newPactdb =
-          PactDb
-         { _pdbPurity = PReadOnly
-         , _pdbRead = _pdbRead pdb
-         , _pdbWrite = \_ _ _ _ -> dbOpDisallowed
-         , _pdbKeys = \_ -> dbOpDisallowed
-         , _pdbCreateUserTable = const dbOpDisallowed
-         , _pdbBeginTx = \_ -> dbOpDisallowed
-         , _pdbCommitTx = dbOpDisallowed
-         , _pdbRollbackTx = dbOpDisallowed
-         , _pdbTxIds = \_ _ -> dbOpDisallowed
-         , _pdbGetTxLog = \_ _ -> dbOpDisallowed
-         }
-  in set cePactDb newPactdb e
+  | view (cePactDb . pdbPurity) e == PSysOnly = pure e
+  | otherwise = do
+      _pdbTxId <- newIORef Nothing
+      let pdb = view cePactDb  e
+          newPactdb =
+              PactDb
+             { _pdbPurity = PReadOnly
+             , _pdbRead = _pdbRead pdb
+             , _pdbWrite = \_ _ _ _ -> dbOpDisallowed
+             , _pdbKeys = \_ -> dbOpDisallowed
+             , _pdbCreateUserTable = const dbOpDisallowed
+             , _pdbBeginTx = \_ -> dbOpDisallowed
+             , _pdbCommitTx = dbOpDisallowed
+             , _pdbRollbackTx = dbOpDisallowed
+             , _pdbTxIds = \_ _ -> dbOpDisallowed
+             , _pdbGetTxLog = \_ _ -> dbOpDisallowed
+             , _pdbTxId
+             }
+      pure $ set cePactDb newPactdb e
 
-sysOnlyEnv :: forall b i m. CEKEnv b i m -> CEKEnv b i m
+sysOnlyEnv :: forall b i m. CEKEnv b i m -> IO (CEKEnv b i m)
 sysOnlyEnv e
-  | view (cePactDb . pdbPurity) e == PSysOnly = e
+  | view (cePactDb . pdbPurity) e == PSysOnly = pure e
   | otherwise =
-  let newPactdb =
-          PactDb
-         { _pdbPurity = PSysOnly
-         , _pdbRead = read'
-         , _pdbWrite = \_ _ _ _ -> dbOpDisallowed
-         , _pdbKeys = \_ -> dbOpDisallowed
-         , _pdbCreateUserTable = const dbOpDisallowed
-         , _pdbBeginTx = \_ -> dbOpDisallowed
-         , _pdbCommitTx = dbOpDisallowed
-         , _pdbRollbackTx = dbOpDisallowed
-         , _pdbTxIds = \_ _ -> dbOpDisallowed
-         , _pdbGetTxLog = \_ _ -> dbOpDisallowed
-         }
-  in set cePactDb newPactdb e
+    do
+      _pdbTxId <- newIORef Nothing
+      let newPactdb =
+              PactDb
+              { _pdbPurity = PSysOnly
+              , _pdbRead = read'
+              , _pdbWrite = \_ _ _ _ -> dbOpDisallowed
+              , _pdbKeys = \_ -> dbOpDisallowed
+              , _pdbCreateUserTable = const dbOpDisallowed
+              , _pdbBeginTx = \_ -> dbOpDisallowed
+              , _pdbCommitTx = dbOpDisallowed
+              , _pdbRollbackTx = dbOpDisallowed
+              , _pdbTxIds = \_ _ -> dbOpDisallowed
+              , _pdbGetTxLog = \_ _ -> dbOpDisallowed
+              , _pdbTxId
+              }
+      pure $ set cePactDb newPactdb e
   where
   pdb = view cePactDb e
   read' :: Domain k v b i -> k -> IO (Maybe v)

pact-core/Pact/Core/Persistence.hs

@@ -40,7 +40,7 @@ import Control.Lens
 import Control.Exception(throwIO, Exception)
 import Control.Applicative((<|>))
 import Data.Default
---import Data.IORef
+import Data.IORef (IORef)
 import Data.Map.Strict(Map)
 --import Data.Maybe(isJust)
 import Data.Text(Text)
@@ -167,6 +167,9 @@ data PactDb b i
   , _pdbRollbackTx :: IO ()
   , _pdbTxIds :: TableName -> TxId -> IO [TxId]
   , _pdbGetTxLog :: TableName -> TxId -> IO [TxLog RowData]
+  , _pdbTxId :: IORef (Maybe TxId)
+    -- ^ A mutable reference to the currently running pact transaction.
+    -- TODO: This field is morally part of
   }
 
 makeClassy ''PactDb

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

@@ -5,12 +5,11 @@ module Pact.Core.Persistence.MockPersistence (
   )where
 
 
-import Control.Monad (unless)
+import Control.Monad (unless, when)
 import Data.Maybe (isJust)
 import Control.Lens ((^?), (^.), ix, view)
 import Data.Map (Map)
 import Data.IORef (IORef, modifyIORef, modifyIORef', newIORef, readIORef, writeIORef)
-import GHC.Word (Word64)
 import Control.Exception(throwIO)
 import qualified Data.Map.Strict as M
 
@@ -34,7 +33,7 @@ mockPactDb = do
   refNS <- newIORef M.empty
   refRb <- newIORef Nothing
   refTxLog <- newIORef mempty
-  refTxId <- newIORef 0
+  refTxId <- newIORef $ Just (TxId 0)
   pure $ PactDb
     { _pdbPurity = PImpure
     , _pdbRead = read' refKs refMod refNS refUsrTbl refPacts
@@ -46,6 +45,7 @@ mockPactDb = do
     , _pdbRollbackTx = rollbackTx refRb refTxLog refMod refKs refUsrTbl
     , _pdbTxIds = txIds refTxLog
     , _pdbGetTxLog = txLog refTxLog
+    , _pdbTxId = refTxId
     }
   where
   beginTx refRb refTxId refTxLog refMod refKs refUsrTbl em = do
@@ -58,13 +58,15 @@ mockPactDb = do
         txl <- readIORef refTxLog
         writeIORef refRb (Just (em, txl, mods, ks, usrTbl))
         tid <- readIORef refTxId
-        pure (Just (TxId tid))
+        pure tid
 
   commitTx refRb refTxId refTxLog refMod refKs refUsrTbl = readIORef refRb >>= \case
     Just (em, txl, mods, ks, usr) -> case em of
       Transactional -> do
         writeIORef refRb Nothing
-        modifyIORef' refTxId (+ 1)
+        mtxid <- readIORef refTxId
+        when (mtxid == Nothing) $ error "Not in a transaction"
+        modifyIORef' refTxId (fmap (\(TxId n) -> TxId (n + 1)))
       Local -> do
         writeIORef refRb Nothing
         writeIORef refMod mods
@@ -168,7 +170,7 @@ mockPactDb = do
     -> IORef (Map ModuleName (ModuleData b i))
     -> IORef (Map NamespaceName Namespace)
     -> IORef (Map TableName (Map RowKey RowData))
-    -> IORef Word64
+    -> IORef (Maybe TxId)
     -> IORef (Map TableName (Map TxId [TxLog RowData]))
     -> IORef (Map DefPactId (Maybe DefPactExec))
     -> WriteType
@@ -190,20 +192,23 @@ mockPactDb = do
     pure (r ^? ix tbl . ix k)
 
   writeToTxLog
-    :: IORef Word64
+    :: IORef (Maybe TxId)
     -> IORef (Map TableName (Map TxId [TxLog RowData]))
     -> TableName
     -> RowKey
     -> RowData
     -> IO ()
   writeToTxLog refTxId refTxLog tbl k rdata = do
-    tid <- readIORef refTxId
-    let entry = M.singleton (TxId tid) [TxLog (toUserTable tbl) (k ^. rowKey) rdata]
-    modifyIORef' refTxLog (M.insertWith (M.unionWith (<>)) tbl entry)
+    mtid <- readIORef refTxId
+    case mtid of
+      Nothing -> pure ()
+      Just tid -> do
+        let entry = M.singleton tid [TxLog (toUserTable tbl) (k ^. rowKey) rdata]
+        modifyIORef' refTxLog (M.insertWith (M.unionWith (<>)) tbl entry)
 
   writeRowData
     :: IORef (Map TableName (Map RowKey RowData))
-    -> IORef Word64
+    -> IORef (Maybe TxId)
     -> IORef (Map TableName (Map TxId [TxLog RowData]))
     -> TableName
     -> WriteType

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

@@ -1,5 +1,6 @@
 -- |
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Pact.Core.Persistence.SQLite (
@@ -10,6 +11,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Exception.Lifted (bracket)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 -- import qualified Data.Text as T
+import Data.IORef (newIORef)
 import Data.Text (Text)
 import Control.Lens (view)
 import qualified Database.SQLite3 as SQL
@@ -48,6 +50,7 @@ createSysTables db = do
 initializePactDb :: PactSerialise b i -> SQL.Database  -> IO (PactDb b i)
 initializePactDb serial db = do
   createSysTables db
+  _pdbTxId <- newIORef Nothing
   pure $ PactDb
     { _pdbPurity = PImpure
     , _pdbRead = read' serial db
@@ -59,6 +62,7 @@ initializePactDb serial db = do
     , _pdbRollbackTx = rollbackTx db
     , _pdbTxIds = undefined
     , _pdbGetTxLog = undefined
+    , _pdbTxId
     }
 
 commitTx :: SQL.Database -> IO ()

pact-core/Pact/Core/Serialise.hs

@@ -29,7 +29,7 @@ import qualified Pact.Core.Serialise.LegacyPact as LegacyPact
 import qualified Pact.Core.Serialise.CBOR_V1 as V1
 
 data DocumentVersion
-  = V0_CBOR
+  = V1_CBOR
   deriving (Show,Eq, Enum, Bounded)
 
 data Document a
@@ -48,12 +48,12 @@ document = lens getDoc setDoc
 
 decodeVersion :: S.Decoder s DocumentVersion
 decodeVersion = S.decodeWord >>= \case
-  0 -> pure V0_CBOR
+  0 -> pure V1_CBOR
   _ -> fail "unexpected version decoding"
 
 encodeVersion :: DocumentVersion -> S.Encoding
 encodeVersion = \case
-  V0_CBOR -> S.encodeWord 0
+  V1_CBOR -> S.encodeWord 0
 
 
 -- | The main serialization API for Pact entities.
@@ -71,46 +71,46 @@ data PactSerialise b i
   , _decodeRowData :: ByteString -> Maybe (Document RowData)
   }
 
-serialiseCBOR :: PactSerialise RawBuiltin ()
-serialiseCBOR = PactSerialise
+serialisePact :: PactSerialise RawBuiltin ()
+serialisePact = PactSerialise
   { _encodeModuleData = docEncode V1.encodeModuleData
   , _decodeModuleData = \bs ->
       LegacyDocument <$> LegacyPact.decodeModuleData bs
       <|> docDecode bs (\case
-                           V0_CBOR -> V1.decodeModuleData
+                           V1_CBOR -> V1.decodeModuleData
                        )
 
   , _encodeKeySet = docEncode V1.encodeKeySet
   , _decodeKeySet = \bs ->
       LegacyDocument <$> LegacyPact.decodeKeySet bs
       <|> docDecode bs (\case
-                           V0_CBOR -> V1.decodeKeySet
+                           V1_CBOR -> V1.decodeKeySet
                        )
 
   , _encodeDefPactExec = docEncode V1.encodeDefPactExec
   , _decodeDefPactExec = \bs ->
       LegacyDocument <$> LegacyPact.decodeDefPactExec bs
       <|> docDecode bs (\case
-                           V0_CBOR -> V1.decodeDefPactExec
+                           V1_CBOR -> V1.decodeDefPactExec
                        )
 
   , _encodeNamespace = docEncode V1.encodeNamespace
   , _decodeNamespace = \bs ->
       LegacyDocument <$> LegacyPact.decodeNamespace bs
       <|> docDecode bs (\case
-                           V0_CBOR -> V1.decodeNamespace
+                           V1_CBOR -> V1.decodeNamespace
                        )
 
   , _encodeRowData = docEncode V1.encodeRowData
   , _decodeRowData = \bs ->
       LegacyDocument <$> LegacyPact.decodeRowData bs
       <|> docDecode bs (\case
-                           V0_CBOR -> V1.decodeRowData
+                           V1_CBOR -> V1.decodeRowData
                        )
   }
   where
     docEncode :: (a -> ByteString) -> a -> ByteString
-    docEncode enc o = toStrictByteString (encodeVersion V0_CBOR <> S.encodeBytes (enc o))
+    docEncode enc o = toStrictByteString (encodeVersion V1_CBOR <> S.encodeBytes (enc o))
 
     docDecode :: ByteString -> (DocumentVersion -> ByteString -> Maybe a) -> Maybe (Document a)
     docDecode bs dec = case deserialiseFromBytes (liftA2 (,) decodeVersion S.decodeBytes) (fromStrict bs) of