Provide access to the plt block state in Haskell

concordium-consensus/src/Concordium/PLTScheduler.hs

@@ -1,41 +1,180 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- |
 -- Bindings into the @plt-scheduler@ Rust library exposing safe wrappers.
 --
 -- Each foreign imported function must match the signature of functions found in @plt-scheduler/src/ffi.rs@.
 module Concordium.PLTScheduler (
     executeTransaction,
+    ExecutionOutcome (..),
+    ExecutionAccepts (..),
+    UpdateTokenAccountBalanceCallback,
 ) where
 
+import Control.Monad.IO.Class (liftIO)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Unsafe as BS
 import qualified Data.Word as Word
 import qualified Foreign as FFI
 import qualified Foreign.C.Types as FFI
 
+import qualified Concordium.GlobalState.ContractStateFFIHelpers as FFI
+import qualified Concordium.GlobalState.Persistent.BlobStore as BlobStore
+import qualified Concordium.GlobalState.Persistent.BlockState.ProtocolLevelTokens as Tokens
+import qualified Concordium.PLTScheduler.PLTBlockState as PLTBlockState
+import qualified Concordium.Types as Types
+import qualified Concordium.Types.Tokens as Tokens
+import qualified Data.FixedByteString as FixedByteString
+
 -- | Execute a transaction payload modifying the `block_state` accordingly.
--- The caller must ensure to rollback state changes in case of the transaction being rejected.
 --
 -- See @execute_transaction@ in @plt-scheduler@ rust crate for details.
 executeTransaction ::
+    (BlobStore.MonadBlobStore m) =>
+    -- | Block state to mutate.
+    PLTBlockState.PLTBlockState ->
+    -- | Callback for updating the token balance of an account.
+    UpdateTokenAccountBalanceCallback ->
     -- | Transaction payload byte string.
     BS.ByteString ->
-    -- | The events produced or the reject reason.
-    IO (Either () ())
-executeTransaction transactionPayload = do
-    statusCode <- BS.unsafeUseAsCStringLen transactionPayload $ \(transactionPayloadPtr, transactionPayloadLen) -> do
-        ffiExecuteTransaction (FFI.castPtr transactionPayloadPtr) (fromIntegral transactionPayloadLen)
-    case statusCode of
-        0 -> return $ Right ()
-        1 -> return $ Left ()
-        _ -> error "Unexpected status code from calling 'ffiExecuteTransaction'"
+    -- | The account index of the account which signed as the sender of the transaction.
+    Types.AccountIndex ->
+    -- | The account address of the account which signed as the sender of the transaction.
+    Types.AccountAddress ->
+    -- | Remaining energy.
+    Types.Energy ->
+    -- | Outcome of the execution
+    m ExecutionOutcome
+executeTransaction
+    blockState
+    updateTokenAccountBalanceCallback
+    transactionPayload
+    senderAccountIndex
+    (Types.AccountAddress senderAccountAddress)
+    remainingEnergy = do
+        loadCallback <- fst <$> BlobStore.getCallbacks
+        liftIO $ FFI.alloca $ \remainingEnergyOut -> FFI.alloca $ \updatedBlockStatePtrOut -> do
+            updateTokenAccountBalanceCallbackPtr <- wrapUpdateTokenAccountBalanceCallback updateTokenAccountBalanceCallback
+            -- Invoke the ffi call
+            statusCode <- PLTBlockState.withPLTBlockState blockState $ \blockStatePtr ->
+                FixedByteString.withPtrReadOnly senderAccountAddress $ \senderAccountAddressPtr ->
+                    BS.unsafeUseAsCStringLen transactionPayload $
+                        \(transactionPayloadPtr, transactionPayloadLen) ->
+                            ffiExecuteTransaction
+                                loadCallback
+                                updateTokenAccountBalanceCallbackPtr
+                                blockStatePtr
+                                (FFI.castPtr transactionPayloadPtr)
+                                (fromIntegral transactionPayloadLen)
+                                (fromIntegral senderAccountIndex)
+                                senderAccountAddressPtr
+                                (fromIntegral remainingEnergy)
+                                updatedBlockStatePtrOut
+                                remainingEnergyOut
+            -- Process the and construct the outcome
+            newRemainingEnergy <- fromIntegral <$> FFI.peek remainingEnergyOut
+            status <- case statusCode of
+                0 -> do
+                    updatedBlockState <- FFI.peek updatedBlockStatePtrOut >>= PLTBlockState.wrapFFIPtr
+                    return $
+                        Right
+                            ExecutionAccepts
+                                { eaUpdatedPLTBlockState = updatedBlockState,
+                                  eaEvents = ()
+                                }
+                1 -> return $ Left ()
+                _ -> error "Unexpected status code from calling 'ffiExecuteTransaction'"
+            return
+                ExecutionOutcome
+                    { erRemainingEnergy = newRemainingEnergy,
+                      erStatus = status
+                    }
 
 foreign import ccall "ffi_execute_transaction"
     ffiExecuteTransaction ::
+        -- | Called to read data from blob store.
+        FFI.LoadCallback ->
+        -- | Called to set the token account balance in the haskell-managed block state.
+        UpdateTokenAccountBalanceCallbackPtr ->
+        -- | Pointer to the starting block state.
+        FFI.Ptr PLTBlockState.PLTBlockState ->
         -- | Pointer to transaction payload bytes.
         FFI.Ptr Word.Word8 ->
         -- | Byte length of transaction payload.
         FFI.CSize ->
+        -- | The account index of the account which signed as the sender of the transaction.
+        Word.Word64 ->
+        -- | Pointer to 32 bytes representing the account address of the account which signed as the
+        -- sender of the transaction.
+        FFI.Ptr Word.Word8 ->
+        -- | Remaining energy
+        Word.Word64 ->
+        -- | Output location for the updated block state.
+        FFI.Ptr (FFI.Ptr PLTBlockState.PLTBlockState) ->
+        -- | Output location for the remaining energy after execution.
+        FFI.Ptr Word.Word64 ->
         -- | Status code
         IO Word.Word8
+
+-- | The outcome of executing a transaction using the PLT scheduler.
+data ExecutionOutcome = ExecutionOutcome
+    { -- | The amount of energy remaining after the execution.
+      erRemainingEnergy :: Types.Energy,
+      -- | The resulting execution status.
+      erStatus :: Either () ExecutionAccepts
+    }
+
+-- | Additional execution outcome when the transaction gets accepted by the PLT scheduler.
+data ExecutionAccepts = ExecutionAccepts
+    { -- | The updated PLT block state after the execution
+      eaUpdatedPLTBlockState :: PLTBlockState.PLTBlockState,
+      -- | Events produced during the execution
+      eaEvents :: ()
+    }
+
+-- | Callback function for updating a token account balance.
+type UpdateTokenAccountBalanceCallback =
+    -- | Index of the account to update a token balance for.
+    Types.AccountIndex ->
+    -- | Index of the token to update the balance of.
+    Tokens.TokenIndex ->
+    -- | The token amount to add to the balance.
+    Tokens.TokenRawAmount ->
+    -- | The token amount to subtract from the balance.
+    Tokens.TokenRawAmount ->
+    -- | Status code, where non-null represents a balance overflow.
+    IO Bool
+
+-- | Internal helper function for mapping the `UpdateTokenAccountBalanceCallback` into the more
+-- low-level function pointer which can be passed in FFI.
+wrapUpdateTokenAccountBalanceCallback :: UpdateTokenAccountBalanceCallback -> IO UpdateTokenAccountBalanceCallbackPtr
+wrapUpdateTokenAccountBalanceCallback callback =
+    ffiWrapUpdateTokenAccountBalanceCallback $ wrapped
+  where
+    wrapped :: UpdateTokenAccountBalanceCallbackFFI
+    wrapped accountIndex tokenIndex add remove = do
+        overflow <- callback (fromIntegral accountIndex) (fromIntegral tokenIndex) (fromIntegral add) (fromIntegral remove)
+        return $ if overflow then 1 else 0
+
+-- | Callback function for updating a token account balance.
+--
+-- This is passed as a function pointer in FFI to call, see also `UpdateTokenAccountBalanceCallback`
+-- for the more type-safe variant.
+type UpdateTokenAccountBalanceCallbackFFI =
+    -- | Index of the account to update a token balance for.
+    Word.Word64 ->
+    -- | Index of the token to update the balance of.
+    Word.Word64 ->
+    -- | The token amount to add to the balance.
+    Word.Word64 ->
+    -- | The token amount to subtract from the balance.
+    Word.Word64 ->
+    -- | Status code, where non-null represents a balance overflow.
+    IO Word.Word8
+
+-- | The callback function pointer type for updating a token account balance.
+type UpdateTokenAccountBalanceCallbackPtr = FFI.FunPtr UpdateTokenAccountBalanceCallbackFFI
+
+-- | Function to wrap Haskell functions or closures into a function pointer which can be passed over
+-- FFI.
+foreign import ccall "wrapper"
+    ffiWrapUpdateTokenAccountBalanceCallback ::
+        UpdateTokenAccountBalanceCallbackFFI -> IO UpdateTokenAccountBalanceCallbackPtr

concordium-consensus/src/Concordium/PLTScheduler/PLTBlockState.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE DerivingVia #-}
+
+-- | Bindings to the PLT block state implementation found in @plt-scheduler/block_state.rs@.
+module Concordium.PLTScheduler.PLTBlockState (
+    PLTBlockState,
+    empty,
+    wrapFFIPtr,
+    withPLTBlockState,
+    migrate,
+    Hash,
+    -- | Get the inner @SHA256.Hash@.
+    innerSha256Hash,
+) where
+
+import qualified Data.Serialize as Serialize
+import qualified Foreign as FFI
+
+import qualified Concordium.Crypto.SHA256 as SHA256
+import qualified Concordium.GlobalState.ContractStateFFIHelpers as FFI
+import qualified Concordium.GlobalState.Persistent.BlobStore as BlobStore
+import qualified Concordium.Types.HashableTo as Hashable
+import Control.Monad.Trans (lift, liftIO)
+import qualified Data.FixedByteString as FixedByteString
+
+-- | Opaque pointer to a immutable PLT block state save-point managed by the rust library.
+--
+-- Memory is deallocated using a finalizer.
+newtype PLTBlockState = PLTBlockState (FFI.ForeignPtr PLTBlockState)
+
+-- | Helper function to convert a raw pointer passed by the Rust library into a `PLTBlockState` object.
+wrapFFIPtr :: FFI.Ptr PLTBlockState -> IO PLTBlockState
+wrapFFIPtr blockStatePtr = PLTBlockState <$> FFI.newForeignPtr ffiFreePLTBlockState blockStatePtr
+
+-- | Deallocate a pointer to `PLTBlockState`.
+foreign import ccall unsafe "&ffi_free_plt_block_state"
+    ffiFreePLTBlockState :: FFI.FinalizerPtr PLTBlockState
+
+-- | Get temporary access to the block state pointer. The pointer should not be
+-- leaked from the computation.
+--
+-- This ensures the finalizer is not called until the computation is over.
+withPLTBlockState :: PLTBlockState -> (FFI.Ptr PLTBlockState -> IO a) -> IO a
+withPLTBlockState (PLTBlockState foreignPtr) = FFI.withForeignPtr foreignPtr
+
+-- | Allocate new empty block state
+empty :: (BlobStore.MonadBlobStore m) => m PLTBlockState
+empty = liftIO $ do
+    state <- ffiEmptyPLTBlockState
+    wrapFFIPtr state
+
+foreign import ccall "ffi_empty_plt_block_state"
+    ffiEmptyPLTBlockState :: IO (FFI.Ptr PLTBlockState)
+
+instance (BlobStore.MonadBlobStore m) => BlobStore.BlobStorable m PLTBlockState where
+    load = do
+        blobRef <- Serialize.get
+        pure $! do
+            loadCallback <- fst <$> BlobStore.getCallbacks
+            liftIO $! do
+                blockState <- ffiLoadPLTBlockState loadCallback blobRef
+                wrapFFIPtr blockState
+    storeUpdate pltBlockState = do
+        storeCallback <- snd <$> BlobStore.getCallbacks
+        blobRef <- liftIO $ withPLTBlockState pltBlockState $ ffiStorePLTBlockState storeCallback
+        return (Serialize.put blobRef, pltBlockState)
+
+-- | Load PLT block state from the given disk reference.
+foreign import ccall "ffi_load_plt_block_state"
+    ffiLoadPLTBlockState ::
+        -- | Called to read data from blob store.
+        FFI.LoadCallback ->
+        -- | Reference in the blob store.
+        BlobStore.BlobRef PLTBlockState ->
+        -- | Pointer to the loaded block state.
+        IO (FFI.Ptr PLTBlockState)
+
+-- | Write out the block state using the provided callback, and return a `BlobRef`.
+foreign import ccall "ffi_store_plt_block_state"
+    ffiStorePLTBlockState ::
+        -- | The provided closure is called to write data to blob store.
+        FFI.StoreCallback ->
+        -- | Pointer to the block state to write.
+        FFI.Ptr PLTBlockState ->
+        -- | New reference in the blob store.
+        IO (BlobStore.BlobRef PLTBlockState)
+
+instance (BlobStore.MonadBlobStore m) => BlobStore.Cacheable m PLTBlockState where
+    cache blockState = do
+        loadCallback <- fst <$> BlobStore.getCallbacks
+        liftIO $! withPLTBlockState blockState (ffiCachePLTBlockState loadCallback)
+        return blockState
+
+-- | Cache block state into memory.
+foreign import ccall "ffi_cache_plt_block_state"
+    ffiCachePLTBlockState ::
+        -- | Called to read data from blob store.
+        FFI.LoadCallback ->
+        -- | Pointer to the block state to cache into memory.
+        FFI.Ptr PLTBlockState ->
+        IO ()
+
+-- | The hash of some `PLTBlockState`.
+newtype Hash = Hash {innerSha256Hash :: SHA256.Hash}
+    deriving newtype (Eq, Ord, Show, Serialize.Serialize)
+
+instance (BlobStore.MonadBlobStore m) => Hashable.MHashableTo m Hash PLTBlockState where
+    getHashM blockState = do
+        loadCallback <- fst <$> BlobStore.getCallbacks
+        ((), hash) <-
+            liftIO $
+                withPLTBlockState blockState $
+                    FixedByteString.createWith . ffiHashPLTBlockState loadCallback
+        return $ Hash (SHA256.Hash hash)
+
+-- | Compute the hash of the block state.
+foreign import ccall "ffi_hash_plt_block_state"
+    ffiHashPLTBlockState ::
+        -- | Called to read data from blob store.
+        FFI.LoadCallback ->
+        -- | Pointer to the block state to write.
+        FFI.Ptr PLTBlockState ->
+        -- | Pointer to write destination of the hash
+        FFI.Ptr FFI.Word8 ->
+        IO ()
+
+-- | Run migration during a protocol update.
+migrate ::
+    (BlobStore.SupportMigration m t) =>
+    -- | Current block state
+    PLTBlockState ->
+    -- | New migrated block state
+    t m PLTBlockState
+migrate currentState = do
+    loadCallback <- fst <$> lift BlobStore.getCallbacks
+    storeCallback <- snd <$> BlobStore.getCallbacks
+    newState <- liftIO $ withPLTBlockState currentState $ ffiMigratePLTBlockState loadCallback storeCallback
+    liftIO $ PLTBlockState <$> FFI.newForeignPtr ffiFreePLTBlockState newState
+
+-- | Migrate PLT block state from one blob store to another.
+foreign import ccall "ffi_migrate_plt_block_state"
+    ffiMigratePLTBlockState ::
+        -- | Called to read data from the old blob store.
+        FFI.LoadCallback ->
+        -- | Called to write data to the new blob store.
+        FFI.StoreCallback ->
+        -- | Pointer to the old block state.
+        FFI.Ptr PLTBlockState ->
+        -- | Pointer to the new block state.
+        IO (FFI.Ptr PLTBlockState)

plt/plt-scheduler/Cargo.toml

@@ -14,3 +14,4 @@ concordium_base.workspace = true
 plt-token-module.workspace = true
 derive_more = { version = "2.1.0", features = ["into", "from"] }
 libc = { workspace = true, optional = true }
+thiserror = "2.0.17"