Move txid management to backend (#491)

src-ghc/Pact/Bench.hs

@@ -16,7 +16,6 @@ import Data.Default
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
-import System.CPUTime
 import System.Directory
 import Unsafe.Coerce
 
@@ -82,7 +81,7 @@ loadBenchModule db = do
            (object ["keyset" .= object ["keys" .= ["benchadmin"::Text], "pred" .= (">"::Text)]])
            Nothing
            pactInitialHash
-  let e = setupEvalEnv db entity (Transactional 1) md initRefStore
+  let e = setupEvalEnv db entity Transactional md initRefStore
           freeGasEnv permissiveNamespacePolicy noSPVSupport def
   void $ evalExec e pc
   (benchMod,_) <- runEval def e $ getModule (def :: Info) (ModuleName "bench" Nothing)
@@ -98,8 +97,7 @@ benchNFIO bname = bench bname . nfIO
 
 runPactExec :: Maybe (ModuleData Ref) -> PactDbEnv e -> ParsedCode -> IO Value
 runPactExec benchMod dbEnv pc = do
-  t <- Transactional . fromIntegral <$> getCPUTime
-  let e = setupEvalEnv dbEnv entity t (initMsgData pactInitialHash)
+  let e = setupEvalEnv dbEnv entity Transactional (initMsgData pactInitialHash)
           initRefStore freeGasEnv permissiveNamespacePolicy noSPVSupport def
       s = maybe def (initStateModules . HM.singleton (ModuleName "bench" Nothing)) benchMod
   toJSON . _erOutput <$> evalExecState s e pc

src-ghc/Pact/Interpreter.hs

@@ -77,6 +77,7 @@ data EvalResult = EvalResult
   , _erExec :: !(Maybe PactExec)
   , _erGas :: Gas
   , _erLoadedModules :: HashMap ModuleName (ModuleData Ref,Bool)
+  , _erTxId :: !(Maybe TxId)
   } deriving (Eq,Show)
 
 
@@ -114,7 +115,7 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd =
     _eeRefStore = refStore
   , _eeMsgSigs = mdSigs msgData
   , _eeMsgBody = mdData msgData
-  , _eeTxId = modeToTx mode
+  , _eeMode = mode
   , _eeEntity = ent
   , _eePactStep = mdStep msgData
   , _eePactDb = pdPactDb dbEnv
@@ -126,8 +127,6 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd =
   , _eeSPVSupport = spv
   , _eePublicData = pd
   }
-  where modeToTx (Transactional t) = Just t
-        modeToTx Local = Nothing
 
 initRefStore :: RefStore
 initRefStore = RefStore nativeDefs
@@ -154,26 +153,23 @@ initSchema PactDbEnv {..} = createSchema pdPactDbVar
 
 interpret :: EvalState -> EvalEnv e -> Either PactContinuation [Term Name] -> IO EvalResult
 interpret initState evalEnv terms = do
-  let tx = _eeTxId evalEnv
-  ((rs,logs),state) <-
-    runEval initState evalEnv $ evalTerms tx terms
+  ((rs,logs,txid),state) <-
+    runEval initState evalEnv $ evalTerms terms
   let gas = _evalGas state
       pactExec = _evalPactExec state
       modules = _rsLoadedModules $ _evalRefs state
   -- output uses lenient conversion
-  return $! EvalResult terms (map toPactValueLenient rs) logs pactExec gas modules
+  return $! EvalResult terms (map toPactValueLenient rs) logs pactExec gas modules txid
 
-evalTerms :: Maybe TxId -> Either PactContinuation [Term Name] -> Eval e ([Term Name],[TxLog Value])
-evalTerms tx terms = do
+evalTerms :: Either PactContinuation [Term Name] -> Eval e ([Term Name],[TxLog Value],Maybe TxId)
+evalTerms terms = do
   let safeRollback =
         void (try (evalRollbackTx def) :: Eval e (Either SomeException ()))
   handle (\(e :: SomeException) -> safeRollback >> throwM e) $ do
-        evalBeginTx def
+        txid <- evalBeginTx def
         rs <- case terms of
           Right ts -> mapM eval ts
           Left pc -> (:[]) <$> Eval.evalContinuation pc
-        logs <- case tx of
-          Just _ -> evalCommitTx def
-          Nothing -> evalRollbackTx def >> return []
-        return (rs,logs)
+        logs <- evalCommitTx def
+        return (rs,logs,txid)
 {-# INLINE evalTerms #-}

src-ghc/Pact/MockDb.hs

@@ -62,7 +62,7 @@ pactdb (MockDb (MockRead r) (MockKeys ks) (MockTxIds tids) (MockGetUserTableInfo
   ,
   _getUserTableInfo = uti
   ,
-  _beginTx = \_t -> rc ()
+  _beginTx = \_t -> rc Nothing
   ,
   _commitTx = c
   ,

src-ghc/Pact/Persist/SQLite.hs

@@ -26,6 +26,7 @@ import System.Directory
 import Control.Monad.State
 
 import Pact.Persist
+import Pact.Types.Persistence
 import Pact.Types.Pretty
 import Pact.Types.SQLite
 import Pact.Types.Util (AsString(..))
@@ -235,11 +236,11 @@ _test = do
   void $ closeSQLite e
   e' <- refresh e
   (`evalStateT` e') $ do
-    run $ beginTx p True
+    run $ beginTx p Transactional
     run $ createTable p dt
     run $ createTable p tt
     run $ commitTx p
-    run $ beginTx p True
+    run $ beginTx p Transactional
     run $ writeValue p dt Insert "stuff" (String "hello")
     run $ writeValue p dt Insert "tough" (String "goodbye")
     run $ writeValue p tt Write 1 (String "txy goodness")
@@ -251,7 +252,7 @@ _test = do
     run (queryKeys p dt (Just (KQKey KGTE "stuff"))) >>= liftIO . print
     run (query p tt (Just (KQKey KGT 0 `kAnd` KQKey KLT 2))) >>=
       (liftIO . (print :: [(TxKey,Value)] -> IO ()))
-    run $ beginTx p True
+    run $ beginTx p Transactional
     run $ writeValue p tt Update 2 (String "txalicious-2!")
     run (readValue p tt 2) >>= (liftIO . (print :: Maybe Value -> IO ()))
     run $ rollbackTx p

src-ghc/Pact/PersistPactDb/Regression.hs

@@ -8,6 +8,7 @@ module Pact.PersistPactDb.Regression
 
 import Control.Concurrent.MVar
 import Control.Exception
+import Control.Monad
 import qualified Data.Map.Strict as M
 import qualified Data.HashMap.Strict as HM
 import Control.Lens hiding ((.=))
@@ -49,8 +50,7 @@ runRegression :: DbEnv p -> IO (MVar (DbEnv p))
 runRegression p = do
   v <- newMVar p
   createSchema v
-  let t1 = 1
-  t2 <- begin v (Just t1)
+  (Just t1) <- begin v
   let user1 = "user1"
       usert = UserTables user1
       toPV :: ToTerm a => a -> PactValue
@@ -62,7 +62,7 @@ runRegression p = do
             ]
      ]
     (commit v)
-  t3 <- begin v t2
+  void $ begin v
   assertEquals' "user table info correct" "someModule" $ _getUserTableInfo pactdb user1 v
   let row = ObjectMap $ M.fromList [("gah",PLiteral (LDecimal 123.454345))]
   _writeRow pactdb Insert usert "key1" row v
@@ -98,9 +98,9 @@ runRegression p = do
             }
     ]
     (commit v)
-  _t4 <- begin v t3
+  void $ begin v
   tids <- _txids pactdb user1 t1 v
-  assertEquals "user txids" [2] tids
+  assertEquals "user txids" [1] tids
   assertEquals' "user txlogs"
     [TxLog "USER_user1" "key1" row,
      TxLog "USER_user1" "key1" row'] $
@@ -116,10 +116,8 @@ runRegression p = do
 toTerm' :: ToTerm a => a -> Term Name
 toTerm' = toTerm
 
-begin :: MVar (DbEnv p) -> Maybe TxId -> IO (Maybe TxId)
-begin v t = do
-  _beginTx pactdb t v
-  return (fmap succ t)
+begin :: MVar (DbEnv p) -> IO (Maybe TxId)
+begin v = _beginTx pactdb Transactional v
 
 commit :: MVar (DbEnv p) -> IO [TxLog Value]
 commit v = _commitTx pactdb v

src-ghc/Pact/Server/PactService.hs

@@ -68,7 +68,7 @@ initPactService CommandConfig {..} loggers = do
 applyCmd :: Logger -> Maybe EntityName -> PactDbEnv p -> MVar CommandState ->
             GasModel -> Word64 -> Int64 -> ExecutionMode -> Command a ->
             ProcessedCommand PublicMeta ParsedCode -> IO CommandResult
-applyCmd _ _ _ _ _ _ _ ex cmd (ProcFail s) = return $ jsonResult ex (cmdToRequestKey cmd) (Gas 0) s
+applyCmd _ _ _ _ _ _ _ _ cmd (ProcFail s) = return $ jsonResult Nothing (cmdToRequestKey cmd) (Gas 0) s
 applyCmd logger conf dbv cv gasModel bh bt exMode _ (ProcSucc cmd) = do
   let pubMeta = _pMeta $ _cmdPayload cmd
       (ParsedDecimal gasPrice) = _pmGasPrice pubMeta
@@ -83,15 +83,12 @@ applyCmd logger conf dbv cv gasModel bh bt exMode _ (ProcSucc cmd) = do
       return cr
     Left e -> do
       logLog logger "ERROR" $ "tx failure for requestKey: " ++ show (cmdToRequestKey cmd) ++ ": " ++ show e
-      return $ jsonResult exMode (cmdToRequestKey cmd) (Gas 0) $
+      return $ jsonResult Nothing (cmdToRequestKey cmd) (Gas 0) $
                CommandError "Command execution failed" (Just $ show e)
 
-jsonResult :: ToJSON a => ExecutionMode -> RequestKey -> Gas -> a -> CommandResult
-jsonResult ex cmd gas a = CommandResult cmd (exToTx ex) (toJSON a) gas
+jsonResult :: ToJSON a => Maybe TxId -> RequestKey -> Gas -> a -> CommandResult
+jsonResult tx cmd gas a = CommandResult cmd tx (toJSON a) gas
 
-exToTx :: ExecutionMode -> Maybe TxId
-exToTx (Transactional t) = Just t
-exToTx Local = Nothing
 
 runPayload :: Command (Payload PublicMeta ParsedCode) -> CommandM p CommandResult
 runPayload c@Command{..} = case (_pPayload _cmdPayload) of
@@ -114,7 +111,7 @@ applyExec rk hsh signers (ExecMsg parsedCode edata) = do
         Just cmdPact -> M.insert (_pePactId cmdPact) cmdPact pacts
   void $ liftIO $ swapMVar _ceState $ CommandState newPacts
   mapM_ (\p -> liftIO $ logLog _ceLogger "DEBUG" $ "applyExec: new pact added: " ++ show p) newCmdPact
-  return $ jsonResult _ceMode rk _erGas $ CommandSuccess (last _erOutput)
+  return $ jsonResult _erTxId rk _erGas $ CommandSuccess (last _erOutput)
 
 handlePactExec :: Either PactContinuation [Term Name] -> PactExec -> CommandM p (Maybe PactExec)
 handlePactExec (Left pc) _ = throwCmdEx $ "handlePactExec: internal error, continuation input: " ++ show pc
@@ -127,39 +124,36 @@ handlePactExec (Right em) pe = do
 applyContinuation :: RequestKey -> PactHash -> [Signer] -> ContMsg -> CommandM p CommandResult
 applyContinuation rk hsh signers msg@ContMsg{..} = do
   env@CommandEnv{..} <- ask
-  case _ceMode of
-    Local -> throwCmdEx "Local continuation exec not supported"
-    Transactional _ -> do
-      state@CommandState{..} <- liftIO $ readMVar _ceState
-      case M.lookup _cmPactId _csPacts of
-        Nothing -> throwCmdEx $ "applyContinuation: pact ID not found: " ++ show _cmPactId
-        Just PactExec{..} -> do
-          -- Verify valid ContMsg Step
-          when (_cmStep < 0 || _cmStep >= _peStepCount) $ throwCmdEx $ "Invalid step value: " ++ show _cmStep
+  state@CommandState{..} <- liftIO $ readMVar _ceState
+  case M.lookup _cmPactId _csPacts of
+    Nothing -> throwCmdEx $ "applyContinuation: pact ID not found: " ++ show _cmPactId
+    Just PactExec{..} -> do
+      -- Verify valid ContMsg Step
+      when (_cmStep < 0 || _cmStep >= _peStepCount) $ throwCmdEx $ "Invalid step value: " ++ show _cmStep
+      if _cmRollback
+        then when (_cmStep /= _peStep) $ throwCmdEx $ "Invalid rollback step value: Received "
+             ++ show _cmStep ++ " but expected " ++ show _peStep
+        else when (_cmStep /= (_peStep + 1)) $ throwCmdEx $ "Invalid continuation step value: Received "
+             ++ show _cmStep ++ " but expected " ++ show (_peStep + 1)
+
+      -- Setup environment and get result
+      let sigs = userSigsToPactKeySet signers
+          pactStep = Just $ PactStep _cmStep _cmRollback _cmPactId (fmap (fmap fromPactValue) _peYield)
+          evalEnv = setupEvalEnv _ceDbEnv _ceEntity _ceMode
+                    (MsgData sigs _cmData pactStep (toUntypedHash hsh)) initRefStore
+                    _ceGasEnv permissiveNamespacePolicy noSPVSupport _cePublicData
+      res <- tryAny (liftIO  $ evalContinuation evalEnv _peContinuation)
+
+      -- Update pacts state
+      case res of
+        Left (SomeException ex) -> throwM ex
+        Right EvalResult{..} -> do
+          exec@PactExec{..} <- maybe (throwCmdEx "No pact execution in continuation exec!")
+                               return _erExec
           if _cmRollback
-            then when (_cmStep /= _peStep) $ throwCmdEx $ "Invalid rollback step value: Received "
-                 ++ show _cmStep ++ " but expected " ++ show _peStep
-            else when (_cmStep /= (_peStep + 1)) $ throwCmdEx $ "Invalid continuation step value: Received "
-                 ++ show _cmStep ++ " but expected " ++ show (_peStep + 1)
-
-          -- Setup environment and get result
-          let sigs = userSigsToPactKeySet signers
-              pactStep = Just $ PactStep _cmStep _cmRollback _cmPactId (fmap (fmap fromPactValue) _peYield)
-              evalEnv = setupEvalEnv _ceDbEnv _ceEntity _ceMode
-                        (MsgData sigs _cmData pactStep (toUntypedHash hsh)) initRefStore
-                        _ceGasEnv permissiveNamespacePolicy noSPVSupport _cePublicData
-          res <- tryAny (liftIO  $ evalContinuation evalEnv _peContinuation)
-
-          -- Update pacts state
-          case res of
-            Left (SomeException ex) -> throwM ex
-            Right EvalResult{..} -> do
-              exec@PactExec{..} <- maybe (throwCmdEx "No pact execution in continuation exec!")
-                                   return _erExec
-              if _cmRollback
-                then rollbackUpdate env msg state
-                else continuationUpdate env msg state exec
-              return $ jsonResult _ceMode rk _erGas $ CommandSuccess (last _erOutput)
+            then rollbackUpdate env msg state
+            else continuationUpdate env msg state exec
+          return $ jsonResult _erTxId rk _erGas $ CommandSuccess (last _erOutput)
 
 rollbackUpdate :: CommandEnv p -> ContMsg -> CommandState -> CommandM p ()
 rollbackUpdate CommandEnv{..} ContMsg{..} CommandState{..} = do

src-ghc/Pact/Server/Server.hs

@@ -20,7 +20,7 @@ module Pact.Server.Server
 import Control.Concurrent
 import Control.Concurrent.Async (async, link, Async(..))
 import Control.Monad
-import Control.Monad.State
+import Control.Monad.IO.Class
 import Control.Exception
 
 import Data.Aeson
@@ -107,26 +107,23 @@ initFastLogger = do
 startCmdThread :: CommandConfig -> InboundPactChan -> HistoryChannel -> ReplayFromDisk -> (String -> IO ()) -> IO ()
 startCmdThread cmdConfig inChan histChan (ReplayFromDisk rp) debugFn = do
   CommandExecInterface {..} <- initPactService cmdConfig (initLoggers debugFn doLog def)
-  void $ (`runStateT` (0 :: TxId)) $ do
-    -- we wait for the history service to light up, possibly giving us backups from disk to replay
-    replayFromDisk' <- liftIO $ takeMVar rp
-    when (null replayFromDisk') $ liftIO $ debugFn "[disk replay]: No replay found"
-    unless (null replayFromDisk') $
-      forM_ replayFromDisk' $ \cmd -> do
-        liftIO $ debugFn $ "[disk replay]: replaying => " ++ show cmd
-        txid <- state (\i -> (i,succ i))
-        liftIO $ _ceiApplyCmd (Transactional txid) cmd
-        -- NB: we don't want to update history with the results from the replay
-    forever $ do
-      -- now we're prepared, so start taking new entries
-      inb <- liftIO $ readInbound inChan
-      case inb of
-        TxCmds cmds -> do
-          liftIO $ debugFn $ "[cmd]: executing " ++ show (length cmds) ++ " command(s)"
-          resps <- forM cmds $ \cmd -> do
-            txid <- state (\i -> (i,succ i))
-            liftIO $ _ceiApplyCmd (Transactional txid) cmd
-          liftIO $ writeHistory histChan $ Update $ HashMap.fromList $ (\cmdr@CommandResult{..} -> (_crReqKey, cmdr)) <$> resps
-        LocalCmd cmd mv -> do
-          CommandResult {..} <- liftIO $ _ceiApplyCmd Local cmd
-          liftIO $ putMVar mv _crResult
+  -- we wait for the history service to light up, possibly giving us backups from disk to replay
+  replayFromDisk' <- liftIO $ takeMVar rp
+  when (null replayFromDisk') $ liftIO $ debugFn "[disk replay]: No replay found"
+  unless (null replayFromDisk') $
+    forM_ replayFromDisk' $ \cmd -> do
+      liftIO $ debugFn $ "[disk replay]: replaying => " ++ show cmd
+      liftIO $ _ceiApplyCmd Transactional cmd
+      -- NB: we don't want to update history with the results from the replay
+  forever $ do
+    -- now we're prepared, so start taking new entries
+    inb <- liftIO $ readInbound inChan
+    case inb of
+      TxCmds cmds -> do
+        liftIO $ debugFn $ "[cmd]: executing " ++ show (length cmds) ++ " command(s)"
+        resps <- forM cmds $ \cmd -> do
+          liftIO $ _ceiApplyCmd Transactional cmd
+        liftIO $ writeHistory histChan $ Update $ HashMap.fromList $ (\cmdr@CommandResult{..} -> (_crReqKey, cmdr)) <$> resps
+      LocalCmd cmd mv -> do
+        CommandResult {..} <- liftIO $ _ceiApplyCmd Local cmd
+        liftIO $ putMVar mv _crResult

src/Pact/Eval.hs

@@ -73,8 +73,8 @@ import Pact.Types.Pretty
 import Pact.Types.Runtime
 
 
-evalBeginTx :: Info -> Eval e ()
-evalBeginTx i = view eeTxId >>= beginTx i
+evalBeginTx :: Info -> Eval e (Maybe TxId)
+evalBeginTx i = view eeMode >>= beginTx i
 {-# INLINE evalBeginTx #-}
 
 evalRollbackTx :: Info -> Eval e ()
@@ -84,10 +84,8 @@ evalRollbackTx i = revokeAllCapabilities >> void (rollbackTx i)
 evalCommitTx :: Info -> Eval e [TxLog Value]
 evalCommitTx i = do
   revokeAllCapabilities
-  tid <- view eeTxId
-  case tid of
-    Nothing -> evalRollbackTx i >> return []
-    Just {} -> commitTx i
+  -- backend now handles local exec
+  commitTx i
 {-# INLINE evalCommitTx #-}
 
 enforceKeySetName :: Info -> KeySetName -> Eval e ()
@@ -688,9 +686,8 @@ applyPact app (TList steps _ i) = do
   use evalPactExec >>= \bad -> unless (isNothing bad) $ evalError i "Nested pact execution, aborting"
   -- get step from environment or create a new one
   PactStep{..} <- view eePactStep >>= \ps -> case ps of
-    Nothing -> view eeTxId >>= \tid -> case tid of
-      Just _ -> view eeHash >>= \hsh -> return $ PactStep 0 False (toPactId hsh) Nothing
-      Nothing -> evalError i "applyPact: pacts not executable in local context"
+    Nothing -> view eeHash >>= \hsh ->
+      return $ PactStep 0 False (toPactId hsh) Nothing
     Just v -> return v
   -- retrieve indicated step from code
   s <- maybe (evalError i $ "applyPact: step not found: " <> pretty _psStep) return $ steps V.!? _psStep

src/Pact/Persist.hs

@@ -134,10 +134,7 @@ instance PactDbValue Namespace                where prettyPactDbValue = pretty
 data Persister s = Persister {
   createTable :: forall k . PactDbKey k => Table k -> Persist s ()
   ,
-  -- | Boolean argument to indicate if this is "transactional for real":
-  -- local execution mode starts a tx knowing full well it will roll back.
-  -- This allows backing layer to be aware of non-transactional exec.
-  beginTx :: Bool -> Persist s ()
+  beginTx :: ExecutionMode -> Persist s ()
   ,
   commitTx :: Persist s ()
   ,