Fix local in pact server

kadena-io · Feb 24, 2025 · 03873e5 · 03873e5
1 parent 6a0cf3e
commit 03873e5
Show file tree

Hide file tree

Showing 2 changed files with 39 additions and 17 deletions.
diff --git a/pact-request-api/Pact/Core/Command/Server.hs b/pact-request-api/Pact/Core/Command/Server.hs
@@ -277,7 +277,7 @@ sendHandler runtime (SendRequest submitBatch) = do
     requestKeys <- forM (_sbCmds submitBatch) $ \cmd -> do
       let requestKey = cmdToRequestKey cmd
       res <- liftIO $ try $! do
-        result <- computeResultAndUpdateState runtime requestKey cmd
+        result <- computeResultAndUpdateState runtime Transactional requestKey cmd
         storeResult <- newEmptyMVar
         writeChan (_srvChan runtime) (StoreMsg requestKey result storeResult)
         readMVar storeResult
@@ -288,8 +288,8 @@ sendHandler runtime (SendRequest submitBatch) = do
         Left (_::SomeException)-> throwError err500
     pure $ SendResponse $ RequestKeys requestKeys
 
-computeResultAndUpdateState :: ServerRuntime -> RequestKey -> Command Text -> IO (CommandResult Hash (PactOnChainError))
-computeResultAndUpdateState runtime requestKey cmd =
+computeResultAndUpdateState :: ServerRuntime -> ExecutionMode -> RequestKey -> Command Text -> IO (CommandResult Hash (PactOnChainError))
+computeResultAndUpdateState runtime execMode requestKey cmd =
   case verifyCommand @(StableEncoding PublicMeta) (fmap E.encodeUtf8 cmd) of
     ProcFail errStr -> do
       let pe = PEExecutionError (EvalError (T.pack errStr)) [] def
@@ -304,7 +304,7 @@ computeResultAndUpdateState runtime requestKey cmd =
             , mdVerifiers = maybe [] (fmap void) mverif
             }
       ge <- mkFreeGasEnv GasLogsDisabled
-      evalExec (RawCode (_pcCode code)) Transactional (_srDbEnv runtime) (_srSPVSupport runtime) ge mempty SimpleNamespacePolicy
+      evalExec (RawCode (_pcCode code)) execMode (_srDbEnv runtime) (_srSPVSupport runtime) ge mempty SimpleNamespacePolicy
         def msgData def parsedCode >>= \case
         Left pe ->
           pure $ pactErrorToCommandResult requestKey pe (Gas 0)
@@ -325,7 +325,7 @@ computeResultAndUpdateState runtime requestKey cmd =
             , _cProof = _cmProof contMsg
             }
       ge <- mkFreeGasEnv GasLogsDisabled
-      evalContinuation Transactional (_srDbEnv runtime) (_srSPVSupport runtime) ge mempty
+      evalContinuation execMode (_srDbEnv runtime) (_srSPVSupport runtime) ge mempty
         SimpleNamespacePolicy def msgData def cont >>= \case
           Left pe ->
             pure $ pactErrorToCommandResult requestKey pe (Gas 0)
@@ -366,7 +366,7 @@ localHandler :: ServerRuntime -> LocalRequest -> Handler LocalResponse
 localHandler env (LocalRequest cmd) = do
   let requestKey = cmdToRequestKey cmd
   res <- liftIO $ try $! do
-    result <- computeResultAndUpdateState env requestKey cmd
+    result <- computeResultAndUpdateState env Local requestKey cmd
     storeResult <- newEmptyMVar
     writeChan (_srvChan env) (StoreMsg requestKey result storeResult)
     (result,) <$> readMVar storeResult

diff --git a/pact/Pact/Core/Persistence/SQLite.hs b/pact/Pact/Core/Persistence/SQLite.hs
@@ -178,15 +178,16 @@ initializePactDb serial db = do
   stmtsCache <- newIORef =<< createSysTables db
   txId <- newIORef (TxId 0)
   txLog <- newIORef []
+  em <- newIORef Nothing
   pure (PactDb
     { _pdbPurity = PImpure
     , _pdbRead = read' serial db stmtsCache
     , _pdbWrite = write' serial db txId txLog stmtsCache
     , _pdbKeys = readKeys db stmtsCache
     , _pdbCreateUserTable = createUserTable db txLog stmtsCache
-    , _pdbBeginTx = liftIO . beginTx txId db txLog
-    , _pdbCommitTx = liftIO $ commitTx txId db txLog
-    , _pdbRollbackTx = liftIO $ rollbackTx db txLog
+    , _pdbBeginTx = liftIO . beginTx em txId db txLog
+    , _pdbCommitTx = liftIO $ commitTx em txId db txLog
+    , _pdbRollbackTx = liftIO $ rollbackTx em db txLog
     }, stmtsCache)
 
 readKeys :: forall k v b i. SQL.Database -> IORef StmtCache -> Domain k v b i -> GasM b i [k]
@@ -229,23 +230,44 @@ readKeys db stmtCache = \case
 
 
 
-commitTx :: IORef TxId -> SQL.Database -> IORef [TxLog ByteString] -> IO [TxLog ByteString]
-commitTx txid db txLog = do
-  _ <- atomicModifyIORef' txid (\old@(TxId n) -> (TxId (succ n), old))
-  SQL.exec db "COMMIT TRANSACTION"
+commitTx
+  :: IORef (Maybe ExecutionMode)
+  -> IORef TxId
+  -> SQL.Database
+  -> IORef [TxLog ByteString]
+  -> IO [TxLog ByteString]
+commitTx emref txid db txLog = do
+  readIORef emref >>= \case
+    Nothing ->
+      pure ()
+    Just em ->
+      case em of
+        Transactional -> do
+          _ <- atomicModifyIORef' txid (\old@(TxId n) -> (TxId (succ n), old))
+          SQL.exec db "COMMIT TRANSACTION"
+        Local -> SQL.exec db "ROLLBACK TRANSACTION"
+  writeIORef emref Nothing
   txls <- atomicModifyIORef' txLog ([],)
   pure $ reverse txls
 
-beginTx :: IORef TxId -> SQL.Database -> IORef [TxLog ByteString] -> ExecutionMode -> IO (Maybe TxId)
-beginTx txid db txLog em = do
+beginTx
+  :: IORef (Maybe ExecutionMode)
+  -> IORef TxId
+  -> SQL.Database
+  -> IORef [TxLog ByteString]
+  -> ExecutionMode
+  -> IO (Maybe TxId)
+beginTx emref txid db txLog em = do
     SQL.exec db "BEGIN TRANSACTION"
     writeIORef txLog []
+    writeIORef emref (Just em)
     case em of
       Transactional -> Just <$> readIORef txid
       Local -> pure Nothing
 
-rollbackTx :: SQL.Database -> IORef [TxLog ByteString] -> IO ()
-rollbackTx db txLog = do
+rollbackTx :: IORef (Maybe ExecutionMode) -> SQL.Database -> IORef [TxLog ByteString] -> IO ()
+rollbackTx emref db txLog = do
+  writeIORef emref Nothing
   SQL.exec db "ROLLBACK TRANSACTION"
   writeIORef txLog []