diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Revision history for tigerbeetle-hs + +## 0.1.0.0 -- 2025-09-05 + +* Initial Version +* Includes: + * basic synchronous and asynchronous client APIs + * raw client APIs + * internal FFI interface diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2024,2025 James King + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of James King nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,148 @@ +# tigerbeetle-hs # + +An unofficial community Haskell client for the financial transaction +database, [Tigerbeetle](https://tigerbeetle.com/). + +The current release supports Tigerbeetle `0.16.33`. + +Note that at this stage the API is subject to change. Consider this +experimental. We will aim to make major version releases have a +stable API. + +This project will aim to support the upstream release cycle and +version policies in future releases. + +The aim of this client library is to provide a high-level, +Haskell-friendly API as well as access to lower level bindings in case +your project needs them. + +It is not a full-featured application framework. + +It is a good starting point for building a framework. Or a snappy +tool. + +## Sync Client + +The synchronous client interface blocks and awaits the result of each +command sent to the server. This is useful mainly for prototyping, +basic scripting, and exploring the API in `ghci`. + +Example usage: + +``` haskell +module Main where + +import Database.TigerBeetle.Account +import Database.TigerBeetle.Client +import qualified Database.TigerBeetle.Client.Sync qualified as Sync + +main :: IO () +main = do + withClient (ClusterId 0) (Address "3000") $ do + result <- createAccounts [CreateAccount (AccountId 0) (LedgerId 0) (AccountCode 100)] + print result +``` + +It is important to note that each action, such as `createAccounts`, +will block and await the response from the server. + +## Async Client + +The asynchronous client interface is what most application developers +should use. It is minimal and requires you to write your own loop and +manage requests. + +Example usage: + +``` haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent +import Control.Concurrent.STM +import Database.TigerBeetle.Account +import Database.TigerBeetle.Client +import qualified Database.TigerBeetle.Client.Async as Async +import Database.TigerBeetle.Response + +main :: IO () +main = do + result <- newTVarIO Nothing + + -- When we initialize a thread, this context will associate responses from the + -- server to the thread that issued the command. + let mainContext = Async.ThreadContext 0 + + let completionCallback _ response = do + atomically $ writeTVar result (Just response) + + -- In this example we're awaiting all responses on the main thread but we + -- could assemble our main loop to run more work in parallel across more + -- threads as needed. + Async.withClient (ClusterId 0) (Address "3000") mainContext completionCallback $ do + Async.createAccounts [CreateAccount (AccountId 9) (LedgerId 9) (AccountCode 1)] + + -- For example, instead of awaiting the result we could feed results from + -- child threads over an STM channel or queue. + -- + -- For this example though we await the result on our TVar. + await result + +await :: TVar (Maybe Response) -> IO () +await result = do + r <- readTVarIO result + case r of + Nothing -> threadDelay 3000 >> await result + Just yay -> print yay +``` + +This API enables you to build the event loop suitable for your +application. Be aware that your callback will need to match responses +to commands on your own. + +Future versions of this library may include a framework based on `STM` +that will give you a common setup based on this API. + +## Commands + +The essential commands are available: + +- Create Accounts +- Create Transfers + +And the essential queries: + +- Lookup Accounts +- Lookup Transfers +- Get Account Balances +- Get Account Transfers +- Query Accounts +- Query Transfers + +What's not supported (yet): + +- _User data_: The Tigerbeetle client has fields for user metadata. + We're planning on supporting this in a Haskell friendly way in the + future. + +## Raw + +The modules in `Database.TigerBeetle.Raw` are meant to be wrappers for +the FFI calls. If you want to build your own higher-level client +library you should be able to use code from this layer as a starting +point that is one level above raw FFI code. + +## Reporting Issues + +Please feel free to report issues or suggest improvements via Github +Issues. + +Include as much detail and context as you can. + +## Contributing + +We welcome contributions from all interested hackers and developers of +all skill levels. + +Interested in contributing? Check out [CONTRIBUTING](CONTRIBUTING.md). diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent +import Control.Concurrent.STM +import Database.TigerBeetle.Account +import Database.TigerBeetle.Client +import Database.TigerBeetle.Client.Async qualified as Async +import Database.TigerBeetle.Response + +main :: IO () +main = do + result <- newTVarIO Nothing + + let completionCallback _ response = do + atomically $ writeTVar result (Just response) + + Async.withClient (ClusterId 0) (Address "3000") (Async.ThreadContext 0) completionCallback $ do + Async.createAccounts [CreateAccount (AccountId 9) (LedgerId 9) (AccountCode 1)] + + await result + +await :: TVar (Maybe Response) -> IO () +await result = do + r <- readTVarIO result + case r of + Nothing -> threadDelay 3000 >> await result + Just yay -> print yay diff --git a/src/Database/TigerBeetle/Account.hs b/src/Database/TigerBeetle/Account.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Account.hs @@ -0,0 +1,113 @@ +module Database.TigerBeetle.Account + ( -- * View Types + AccountId (..) + , AccountCode (..) + , Account (..) + , AccountFlag (..) + , AccountFlags (..) + , AccountBalance (..) + , AccountTransfers (..) + + -- * Command Parameter Types + , CreateAccount (..) + + -- * Query Parameter Types + , AccountBalances (..) + , AccountQuery (..) + , AccountQueryFlag (..) + ) +where + +import Data.Set (Set) +import Data.WideWord +import Data.Word +import Database.TigerBeetle.Code +import Database.TigerBeetle.Ledger +import Database.TigerBeetle.Timestamp + +-- | Identify an 'Account' in the Tigerbeetle database +newtype AccountId = AccountId {getAccountId :: Word128} + deriving (Eq, Show) + +-- | Classifies an account +-- +-- Use these to distinguish "settlement" accounts from "customer" +-- accounts, etc. +newtype AccountCode = AccountCode {getAccountCode :: Word16} + deriving (Eq, Show) + +data AccountFlags + = Linked + | DebitsMustNotExceedCredits + | CreditsMustNotExceedDebits + | History + | Imported + | Closed + deriving (Eq, Ord, Show) + +-- | A TigerBeetle account is a summary of the ledger of events on the +-- account. +data Account = Account + { accountId :: AccountId + , accountDebitsPending :: Integer + , accountDebitsPosted :: Integer + , accountCreditsPending :: Integer + , accountCreditsPosted :: Integer + , accountLedger :: LedgerId + , accountCode :: Code + , accountFlags :: Set AccountFlags + , accountTimestamp :: Timestamp + } + deriving (Eq, Show) + +-- | The result from the account balance query +data AccountBalance = AccountBalance + { accountBalanceDebitsPending :: Integer + , accountBalanceDebitsPosted :: Integer + , accountBalanceCreditsPending :: Integer + , accountBalanceCreditsPosted :: Integer + , accountBalanceTimestamp :: Timestamp + } + deriving (Show, Eq) + +-- | 'Account' creation parameters to pass to the create account +-- command. +data CreateAccount = CreateAccount + { createAccountId :: AccountId + , createAccountLedger :: LedgerId + , createAccountCode :: AccountCode + } + deriving (Eq, Show) + +data AccountFlag = AccountCredits | AccountDebits | AccountReversed + deriving (Bounded, Enum, Eq, Ord, Show) + +-- | Parameters for the account balances query +data AccountBalances = AccountBalances + { balancesAccountId :: AccountId + , balancesFlags :: Set AccountFlag + , balancesLimit :: Int + } + deriving (Eq, Show) + +-- | Parameters for the account transfers query +data AccountTransfers = AccountTransfers + { transfersAccountId :: AccountId + , transfersFlags :: Set AccountFlag + , transfersLimit :: Int + } + deriving (Eq, Show) + +data AccountQueryFlag = AccountQueryReversed + deriving (Eq, Ord, Show) + +-- | Parameters for the accounts query +data AccountQuery = AccountQuery + { accountQueryLedger :: LedgerId + , accountQueryCode :: AccountCode + , accountQueryTimestampMin :: Timestamp + , accountQueryTimestampMax :: Timestamp + , accountQueryLimit :: Int + , accountQueryFlags :: Set AccountQueryFlag + } + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Address.hs b/src/Database/TigerBeetle/Address.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Address.hs @@ -0,0 +1,7 @@ +module Database.TigerBeetle.Address where + +import Data.Text (Text) + +-- | A host address of the Tigerbeetle instance +newtype Address = Address {getAddress :: Text} + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Amount.hs b/src/Database/TigerBeetle/Amount.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Amount.hs @@ -0,0 +1,10 @@ +module Database.TigerBeetle.Amount where + +import Data.WideWord + +-- | An amount of currency in the base unit of that currency +-- +-- Amounts in Tigerbeetle are represented as 128-bit unsigned +-- integers. +newtype Amount = Amount {getAmount :: Word128} + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Client.hs b/src/Database/TigerBeetle/Client.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Client.hs @@ -0,0 +1,19 @@ +module Database.TigerBeetle.Client + ( -- * Re-exports + module Database.TigerBeetle.Account + , module Database.TigerBeetle.Address + , module Database.TigerBeetle.ClusterId + , module Database.TigerBeetle.Code + , module Database.TigerBeetle.Ledger + , module Database.TigerBeetle.Timestamp + , TBResponse (..) + ) +where + +import Database.TigerBeetle.Account +import Database.TigerBeetle.Address +import Database.TigerBeetle.ClusterId +import Database.TigerBeetle.Code +import Database.TigerBeetle.Ledger +import Database.TigerBeetle.Raw.Response +import Database.TigerBeetle.Timestamp diff --git a/src/Database/TigerBeetle/Client/Async.hs b/src/Database/TigerBeetle/Client/Async.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Client/Async.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Client.Async + ( -- * Types + ThreadContext (..) + -- * Connecting + , withClient + -- * Commands + , createAccounts + , createTransfers + -- * Queries + , lookupAccounts + , getAccountBalances + , getAccountTransfers + , queryAccounts + , queryTransfers + ) +where + +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Word +import Database.TigerBeetle.Account +import Database.TigerBeetle.Address +import Database.TigerBeetle.ClusterId +import Database.TigerBeetle.Internal.FFI.Client +import Database.TigerBeetle.Raw.Account qualified as Raw +import Database.TigerBeetle.Raw.Client qualified as Raw +import Database.TigerBeetle.Raw.Response qualified as Raw +import Database.TigerBeetle.Raw.Transfer qualified as Raw +import Database.TigerBeetle.Response +import Database.TigerBeetle.Transfer +import Foreign.C.Types +import Foreign.Storable + +newtype AsyncState = AsyncState {asyncStateClientPtr :: Raw.ClientPtr} + +newtype AsyncClientT m a = AsyncClientT {getAsyncClient :: ReaderT AsyncState m a} + deriving (Applicative, Functor, Monad, MonadIO, MonadReader AsyncState) + +-- | A thread ID that will be associated with a given command. +newtype ThreadContext = ThreadContext {getThreadContext :: Word64} + +-- | Initializes a TigerBeetle client connection to accept commands. +-- +-- Provide a callback to receive the responses from the server. +-- +-- @ +-- callback _ result = print result +-- withClient (ClusterId 0) (Address "3000") (ThreadContext 1) callback $ do +-- createAccounts [CreateAccount 0 0 100] +-- @ +withClient + :: (MonadIO m) + => ClusterId + -> Address + -> ThreadContext + -> (ThreadContext -> Response -> IO ()) + -> AsyncClientT m () + -> m () +withClient clusterId address (ThreadContext userCtxt) callback clientAction = do + cb <- liftIO $ Raw.makeCompletionCallback $ \(CUIntPtr ctx) tbPacketPtr _ resultDataPtr resultLen -> do + tbPacket <- peek tbPacketPtr + tbResponse <- Raw.decodeResponse tbPacket resultDataPtr $ fromIntegral resultLen + callback (ThreadContext ctx) $ toResponse tbResponse + clientInitResult <- liftIO $ Raw.initClient clusterId address (CUIntPtr userCtxt) cb + case clientInitResult of + Left err -> error $ show err + Right clientPtr -> do + let asyncState = AsyncState{asyncStateClientPtr = clientPtr} + (`runReaderT` asyncState) . getAsyncClient $ clientAction + +createAccounts :: (MonadIO m) => [CreateAccount] -> AsyncClientT m () +createAccounts createAccountParams = do + AsyncState{..} <- ask + status <- Raw.submit asyncStateClientPtr Raw.createAccounts createAccountParams + case status of + ClientOk -> pure () + _ -> error $ show status + +lookupAccounts :: (MonadIO m) => [AccountId] -> AsyncClientT m () +lookupAccounts lookupAccountParams = do + AsyncState{..} <- ask + status <- Raw.submit asyncStateClientPtr Raw.lookupAccounts lookupAccountParams + case status of + ClientOk -> pure () + _ -> error $ show status + +getAccountBalances :: (MonadIO m) => [AccountBalances] -> AsyncClientT m () +getAccountBalances accountBalanceParams = do + AsyncState{..} <- ask + status <- Raw.submit asyncStateClientPtr Raw.getAccountBalances accountBalanceParams + case status of + ClientOk -> pure () + _ -> error $ show status + +getAccountTransfers :: (MonadIO m) => [AccountTransfers] -> AsyncClientT m () +getAccountTransfers accountTransferParams = do + AsyncState{..} <- ask + status <- Raw.submit asyncStateClientPtr Raw.getAccountTransfers accountTransferParams + case status of + ClientOk -> pure () + _ -> error $ show status + +-- | Query accounts by the intersection of some fields and time +-- ranges. +-- +-- It is not possible to query more than 8189 accounts +-- atomically. When issuing multiple queries (eg: when paginating the +-- full result set) it can happen that other operations may be +-- interleaved leading to read skew. +-- +-- Note that this can be worked around with a flag in more recent +-- versions of Tigerbeetle. +queryAccounts :: (MonadIO m) => [AccountQuery] -> AsyncClientT m () +queryAccounts queryAccountParams = do + AsyncState{..} <- ask + status <- Raw.submit asyncStateClientPtr Raw.queryAccounts queryAccountParams + case status of + ClientOk -> pure () + _ -> error $ show status + +createTransfers :: (MonadIO m) => [CreateTransfer] -> AsyncClientT m () +createTransfers transferParams = do + AsyncState{..} <- ask + status <- Raw.submit asyncStateClientPtr Raw.createTransfers transferParams + case status of + ClientOk -> pure () + _ -> error $ show status + +-- | Query transfers by the intersection of some fields and time +-- ranges. +-- +-- It is not possible to query more than 8189 transfers +-- atomically. When issuing multiple queries (eg: when paginating the +-- full result set) it can happen that other operations may be +-- interleaved leading to read skew. +-- +-- Note that this can be worked around with a flag in more recent +-- versions of Tigerbeetle. +queryTransfers :: (MonadIO m) => [TransferQuery] -> AsyncClientT m () +queryTransfers transferQueryParams = do + AsyncState{..} <- ask + status <- Raw.submit asyncStateClientPtr Raw.queryTransfers transferQueryParams + case status of + ClientOk -> pure () + _ -> error $ show status diff --git a/src/Database/TigerBeetle/Client/Sync.hs b/src/Database/TigerBeetle/Client/Sync.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Client/Sync.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Client.Sync + ( -- * Connecting + withClient + -- * Commands + , createAccounts + , createTransfers + -- * Queries + , lookupAccounts + , getAccountBalances + , getAccountTransfers + , queryAccounts + , queryTransfers + ) +where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Reader +import Database.TigerBeetle.Account +import Database.TigerBeetle.Address +import Database.TigerBeetle.ClusterId +import Database.TigerBeetle.Internal.FFI.Client +import Database.TigerBeetle.Raw.Account qualified as Raw +import Database.TigerBeetle.Raw.Client qualified as Raw +import Database.TigerBeetle.Raw.Response +import Database.TigerBeetle.Raw.Transfer qualified as Raw +import Database.TigerBeetle.Response +import Database.TigerBeetle.Transfer +import Foreign.Storable + +data SyncState = SyncState + { syncStateClientPtr :: Raw.ClientPtr + , syncStateResultVar :: TVar (Maybe TBResponse) + } + +newtype SyncClientT m a = SyncClientT {getSyncClient :: ReaderT SyncState m a} + deriving (Applicative, Functor, Monad, MonadIO, MonadReader SyncState) + +-- | Initializes a TigerBeetle client connection to accept commands. +-- +-- Commands are blocking and execute synchronously, each one awaiting +-- the response from the server. +withClient :: (MonadIO m) => ClusterId -> Address -> SyncClientT m Response -> m Response +withClient clusterId address clientAction = do + result <- liftIO $ newTVarIO Nothing + cb <- liftIO $ Raw.makeCompletionCallback $ \_ tbPacketPtr _ resultDataPtr resultLen -> do + tbPacket <- peek tbPacketPtr + tbResponse <- decodeResponse tbPacket resultDataPtr $ fromIntegral resultLen + liftIO . atomically $ writeTVar result (Just tbResponse) + clientInitResult <- liftIO $ Raw.initClient clusterId address 0 cb + case clientInitResult of + Left err -> error $ show err + Right clientPtr -> do + let syncState = + SyncState + { syncStateClientPtr = clientPtr + , syncStateResultVar = result + } + (`runReaderT` syncState) . getSyncClient $ clientAction + +createAccounts :: (MonadIO m) => [CreateAccount] -> SyncClientT m Response +createAccounts createAccountParams = do + SyncState{..} <- ask + status <- Raw.submit syncStateClientPtr Raw.createAccounts createAccountParams + case status of + ClientOk -> awaitResult + _ -> error $ show status + +lookupAccounts :: (MonadIO m) => [AccountId] -> SyncClientT m Response +lookupAccounts ids = do + SyncState{..} <- ask + status <- Raw.submit syncStateClientPtr Raw.lookupAccounts ids + case status of + ClientOk -> awaitResult + _ -> error $ show status + +getAccountBalances :: (MonadIO m) => [AccountBalances] -> SyncClientT m Response +getAccountBalances balances = do + SyncState{..} <- ask + status <- Raw.submit syncStateClientPtr Raw.getAccountBalances balances + case status of + ClientOk -> awaitResult + _ -> error $ show status + +getAccountTransfers :: (MonadIO m) => [AccountTransfers] -> SyncClientT m Response +getAccountTransfers transfers = do + SyncState{..} <- ask + status <- Raw.submit syncStateClientPtr Raw.getAccountTransfers transfers + case status of + ClientOk -> awaitResult + _ -> error $ show status + +-- | Query accounts by the intersection of some fields and time +-- ranges. +-- +-- It is not possible to query more than 8189 accounts +-- atomically. When issuing multiple queries (eg: when paginating the +-- full result set) it can happen that other operations may be +-- interleaved leading to read skew. +-- +-- Note that this can be worked around with a flag in more recent +-- versions of Tigerbeetle. +queryAccounts :: (MonadIO m) => [AccountQuery] -> SyncClientT m Response +queryAccounts accountQueries = do + SyncState{..} <- ask + status <- Raw.submit syncStateClientPtr Raw.queryAccounts accountQueries + case status of + ClientOk -> awaitResult + _ -> error $ show status + +createTransfers :: (MonadIO m) => [CreateTransfer] -> SyncClientT m Response +createTransfers transfers = do + SyncState{..} <- ask + status <- Raw.submit syncStateClientPtr Raw.createTransfers transfers + case status of + ClientOk -> awaitResult + _ -> error $ show status + +-- | Query transfers by the intersection of some fields and time +-- ranges. +-- +-- It is not possible to query more than 8189 transfers +-- atomically. When issuing multiple queries (eg: when paginating the +-- full result set) it can happen that other operations may be +-- interleaved leading to read skew. +-- +-- Note that this can be worked around with a flag in more recent +-- versions of Tigerbeetle. +queryTransfers :: (MonadIO m) => [TransferQuery] -> SyncClientT m Response +queryTransfers transferQueries = do + SyncState{..} <- ask + status <- Raw.submit syncStateClientPtr Raw.queryTransfers transferQueries + case status of + ClientOk -> awaitResult + _ -> error $ show status + +awaitResult :: (MonadIO m) => SyncClientT m Response +awaitResult = do + SyncState{..} <- ask + mResult <- liftIO (readTVarIO syncStateResultVar) + case mResult of + Nothing -> liftIO (threadDelay 2000) >> awaitResult + Just pkt -> pure $ toResponse pkt diff --git a/src/Database/TigerBeetle/ClusterId.hs b/src/Database/TigerBeetle/ClusterId.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/ClusterId.hs @@ -0,0 +1,9 @@ +module Database.TigerBeetle.ClusterId where + +import Data.WideWord + +-- | Identifies the cluster of the Tigerbeetle instance +-- +-- Represented as a 128-bit unsigned integer. +newtype ClusterId = ClusterId {getClusterId :: Word128} + deriving newtype (Eq, Show) diff --git a/src/Database/TigerBeetle/Code.hs b/src/Database/TigerBeetle/Code.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Code.hs @@ -0,0 +1,12 @@ +module Database.TigerBeetle.Code where + +import Data.Word + +-- | Classifies an account +-- +-- eg: @100, 101, 102@ are all internal accounts of receivables, +-- settlements, and holds respectively. +-- +-- Represented as an unsigned 16-bit integer. +newtype Code = Code {getCode :: Word16} + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Internal/FFI/Account.hsc b/src/Database/TigerBeetle/Internal/FFI/Account.hsc new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Internal/FFI/Account.hsc @@ -0,0 +1,387 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Internal.FFI.Account where + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import Data.WideWord +import Foreign.Ptr +import Foreign.Storable +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Set (Set) +import Database.TigerBeetle.Internal.FFI.BitFlag (flagsToBitmask, bitmaskToFlags) + +#include "tb_client.h" + +data TBAccountFlags = + Linked + | DebitsMustNotExceedCredits + | CreditsMustNotExceedDebits + | History + | Imported + | Closed + deriving (Enum, Eq, Ord, Show) + +marshallTBAccountFlags :: Set TBAccountFlags -> Word16 +marshallTBAccountFlags = flagsToBitmask + +unmarshallTBAccountFlags :: Word16 -> Set TBAccountFlags +unmarshallTBAccountFlags = bitmaskToFlags + +data TBAccount + = TBAccount + { tbAccountId :: Word128 + , tbAccountDebitsPending :: Word128 + , tbAccountDebitsPosted :: Word128 + , tbAccountCreditsPending :: Word128 + , tbAccountCreditsPosted :: Word128 + , tbAccountUserData128 :: Word128 + , tbAccountUserData64 :: Word64 + , tbAccountUserData32 :: Word32 + , tbAccountReserved :: Word32 + , tbAccountLedger :: Word32 + , tbAccountCode :: Word16 + , tbAccountFlags :: Set TBAccountFlags + , tbAccountTimestamp :: Word64 + } + deriving (Eq, Show) + +instance Storable TBAccount where + sizeOf _ = #{size tb_account_t} + + alignment _ = #{alignment tb_account_t} + + peek ptr = do + tbAccountId <- #{peek tb_account_t, id} ptr + tbAccountDebitsPending <- #{peek tb_account_t, debits_pending} ptr + tbAccountDebitsPosted <- #{peek tb_account_t, debits_posted} ptr + tbAccountCreditsPending <- #{peek tb_account_t, credits_pending} ptr + tbAccountCreditsPosted <- #{peek tb_account_t, credits_posted} ptr + tbAccountUserData128 <- #{peek tb_account_t, user_data_128} ptr + tbAccountUserData64 <- #{peek tb_account_t, user_data_64} ptr + tbAccountUserData32 <- #{peek tb_account_t, user_data_32} ptr + tbAccountReserved <- #{peek tb_account_t, reserved} ptr + tbAccountLedger <- #{peek tb_account_t, ledger} ptr + tbAccountCode <- #{peek tb_account_t, code} ptr + tbAccountFlags <- unmarshallTBAccountFlags <$> #{peek tb_account_t, flags} ptr + tbAccountTimestamp <- #{peek tb_account_t, timestamp} ptr + pure TBAccount{..} + + poke ptr account = do + #{poke tb_account_t, id} ptr account.tbAccountId + #{poke tb_account_t, debits_pending} ptr account.tbAccountDebitsPending + #{poke tb_account_t, debits_posted} ptr account.tbAccountDebitsPosted + #{poke tb_account_t, credits_pending} ptr account.tbAccountCreditsPending + #{poke tb_account_t, credits_posted} ptr account.tbAccountCreditsPosted + #{poke tb_account_t, user_data_128} ptr account.tbAccountUserData128 + #{poke tb_account_t, user_data_64} ptr account.tbAccountUserData64 + #{poke tb_account_t, user_data_32} ptr account.tbAccountUserData32 + #{poke tb_account_t, reserved} ptr account.tbAccountReserved + #{poke tb_account_t, ledger} ptr account.tbAccountLedger + #{poke tb_account_t, code} ptr account.tbAccountCode + #{poke tb_account_t, flags} ptr (marshallTBAccountFlags account.tbAccountFlags) + #{poke tb_account_t, timestamp} ptr account.tbAccountTimestamp + +instance Binary TBAccount where + put account = do + put account.tbAccountId + put account.tbAccountDebitsPending + put account.tbAccountDebitsPosted + put account.tbAccountCreditsPending + put account.tbAccountCreditsPosted + put account.tbAccountUserData128 + put account.tbAccountUserData64 + putWord32le account.tbAccountUserData32 + putWord32le account.tbAccountReserved + putWord32le account.tbAccountLedger + putWord16le account.tbAccountCode + putWord16le . marshallTBAccountFlags $ account.tbAccountFlags + putWord64le account.tbAccountTimestamp + + get = do + tbAccountId <- get + tbAccountDebitsPending <- get + tbAccountDebitsPosted <- get + tbAccountCreditsPending <- get + tbAccountCreditsPosted <- get + tbAccountUserData128 <- get + tbAccountUserData64 <- get + tbAccountUserData32 <- getWord32le + tbAccountReserved <- getWord32le + tbAccountLedger <- getWord32le + tbAccountCode <- getWord16le + tbAccountFlags <- unmarshallTBAccountFlags <$> getWord16le + tbAccountTimestamp <- getWord64le + return TBAccount{..} + +data TBCreateAccountResult = + Ok + | LinkedEventFailed + | LinkedEventChainOpen + | ImportedEventExpected + | ImportedEventNotExpected + | TimestampMustBeZero + | ImportedEventTimestampOutOfRange + | ImportedEventTimestampMustNotAdvance + | ReservedField + | ReservedFlag + | IdMustNotBeZero + | IdMustNotBeIntMax + | ExistsWithDifferentFlags + | ExistsWithDifferentUserData128 + | ExistsWithDifferentUserData64 + | ExistsWithDifferentUserData32 + | ExistsWithDifferentLedger + | ExistsWithDifferentCode + | Exists + | FlagsAreMutuallyExclusive + | DebitsPendingMustBeZero + | DebitsPostedMustBeZero + | CreditsPendingMustBeZero + | CreditsPostedMustBeZero + | LedgerMustNotBeZero + | CodeMustNotBeZero + | ImportedEventTimestampMustNotRegress + deriving (Eq, Ord, Show) + +instance Enum TBCreateAccountResult where + fromEnum Ok = #const TB_CREATE_ACCOUNT_OK + fromEnum LinkedEventFailed = #const TB_CREATE_ACCOUNT_LINKED_EVENT_FAILED + fromEnum LinkedEventChainOpen = #const TB_CREATE_ACCOUNT_LINKED_EVENT_CHAIN_OPEN + fromEnum ImportedEventExpected = #const TB_CREATE_ACCOUNT_IMPORTED_EVENT_EXPECTED + fromEnum ImportedEventNotExpected = #const TB_CREATE_ACCOUNT_IMPORTED_EVENT_NOT_EXPECTED + fromEnum TimestampMustBeZero = #const TB_CREATE_ACCOUNT_TIMESTAMP_MUST_BE_ZERO + fromEnum ImportedEventTimestampOutOfRange = #const TB_CREATE_ACCOUNT_IMPORTED_EVENT_TIMESTAMP_OUT_OF_RANGE + fromEnum ImportedEventTimestampMustNotAdvance = #const TB_CREATE_ACCOUNT_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_ADVANCE + fromEnum ReservedField = #const TB_CREATE_ACCOUNT_RESERVED_FIELD + fromEnum ReservedFlag = #const TB_CREATE_ACCOUNT_RESERVED_FLAG + fromEnum IdMustNotBeZero = #const TB_CREATE_ACCOUNT_ID_MUST_NOT_BE_ZERO + fromEnum IdMustNotBeIntMax = #const TB_CREATE_ACCOUNT_ID_MUST_NOT_BE_INT_MAX + fromEnum ExistsWithDifferentFlags = #const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_FLAGS + fromEnum ExistsWithDifferentUserData128 = #const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_USER_DATA_128 + fromEnum ExistsWithDifferentUserData64 = #const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_USER_DATA_64 + fromEnum ExistsWithDifferentUserData32 = #const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_USER_DATA_32 + fromEnum ExistsWithDifferentLedger = #const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_LEDGER + fromEnum ExistsWithDifferentCode = #const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_CODE + fromEnum Exists = #const TB_CREATE_ACCOUNT_EXISTS + fromEnum FlagsAreMutuallyExclusive = #const TB_CREATE_ACCOUNT_FLAGS_ARE_MUTUALLY_EXCLUSIVE + fromEnum DebitsPendingMustBeZero = #const TB_CREATE_ACCOUNT_DEBITS_PENDING_MUST_BE_ZERO + fromEnum DebitsPostedMustBeZero = #const TB_CREATE_ACCOUNT_DEBITS_POSTED_MUST_BE_ZERO + fromEnum CreditsPendingMustBeZero = #const TB_CREATE_ACCOUNT_CREDITS_PENDING_MUST_BE_ZERO + fromEnum CreditsPostedMustBeZero = #const TB_CREATE_ACCOUNT_CREDITS_POSTED_MUST_BE_ZERO + fromEnum LedgerMustNotBeZero = #const TB_CREATE_ACCOUNT_LEDGER_MUST_NOT_BE_ZERO + fromEnum CodeMustNotBeZero = #const TB_CREATE_ACCOUNT_CODE_MUST_NOT_BE_ZERO + fromEnum ImportedEventTimestampMustNotRegress = #const TB_CREATE_ACCOUNT_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_REGRESS + + toEnum (#const TB_CREATE_ACCOUNT_OK) = Ok + toEnum (#const TB_CREATE_ACCOUNT_LINKED_EVENT_FAILED) = LinkedEventFailed + toEnum (#const TB_CREATE_ACCOUNT_LINKED_EVENT_CHAIN_OPEN) = LinkedEventChainOpen + toEnum (#const TB_CREATE_ACCOUNT_IMPORTED_EVENT_EXPECTED) = ImportedEventExpected + toEnum (#const TB_CREATE_ACCOUNT_IMPORTED_EVENT_NOT_EXPECTED) = ImportedEventNotExpected + toEnum (#const TB_CREATE_ACCOUNT_TIMESTAMP_MUST_BE_ZERO) = TimestampMustBeZero + toEnum (#const TB_CREATE_ACCOUNT_IMPORTED_EVENT_TIMESTAMP_OUT_OF_RANGE) = ImportedEventTimestampOutOfRange + toEnum (#const TB_CREATE_ACCOUNT_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_ADVANCE) = ImportedEventTimestampMustNotAdvance + toEnum (#const TB_CREATE_ACCOUNT_RESERVED_FIELD) = ReservedField + toEnum (#const TB_CREATE_ACCOUNT_RESERVED_FLAG) = ReservedFlag + toEnum (#const TB_CREATE_ACCOUNT_ID_MUST_NOT_BE_ZERO) = IdMustNotBeZero + toEnum (#const TB_CREATE_ACCOUNT_ID_MUST_NOT_BE_INT_MAX) = IdMustNotBeIntMax + toEnum (#const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_FLAGS) = ExistsWithDifferentFlags + toEnum (#const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_USER_DATA_128) = ExistsWithDifferentUserData128 + toEnum (#const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_USER_DATA_64) = ExistsWithDifferentUserData64 + toEnum (#const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_USER_DATA_32) = ExistsWithDifferentUserData32 + toEnum (#const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_LEDGER) = ExistsWithDifferentLedger + toEnum (#const TB_CREATE_ACCOUNT_EXISTS_WITH_DIFFERENT_CODE) = ExistsWithDifferentCode + toEnum (#const TB_CREATE_ACCOUNT_EXISTS) = Exists + toEnum (#const TB_CREATE_ACCOUNT_FLAGS_ARE_MUTUALLY_EXCLUSIVE) = FlagsAreMutuallyExclusive + toEnum (#const TB_CREATE_ACCOUNT_DEBITS_PENDING_MUST_BE_ZERO) = DebitsPendingMustBeZero + toEnum (#const TB_CREATE_ACCOUNT_DEBITS_POSTED_MUST_BE_ZERO) = DebitsPostedMustBeZero + toEnum (#const TB_CREATE_ACCOUNT_CREDITS_PENDING_MUST_BE_ZERO) = CreditsPendingMustBeZero + toEnum (#const TB_CREATE_ACCOUNT_CREDITS_POSTED_MUST_BE_ZERO) = CreditsPostedMustBeZero + toEnum (#const TB_CREATE_ACCOUNT_LEDGER_MUST_NOT_BE_ZERO) = LedgerMustNotBeZero + toEnum (#const TB_CREATE_ACCOUNT_CODE_MUST_NOT_BE_ZERO) = CodeMustNotBeZero + toEnum (#const TB_CREATE_ACCOUNT_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_REGRESS) = ImportedEventTimestampMustNotRegress + toEnum unmatched = error $ "CreateAccountsResult.toEnum: Cannot match " ++ show unmatched + +instance Binary TBCreateAccountResult where + put = putWord32le . marshallTBCreateAccountResult + get = unmarshallTBCreateAccountResult <$> getWord32le + +marshallTBCreateAccountResult :: TBCreateAccountResult -> Word32 +marshallTBCreateAccountResult = fromIntegral . fromEnum + +unmarshallTBCreateAccountResult :: Word32 -> TBCreateAccountResult +unmarshallTBCreateAccountResult = toEnum . fromIntegral + +data TBCreateAccountsResult = TBCreateAccountsResult + { tbCreateAccountsResultIndex :: Word32 + , tbCreateAccountsResultResult :: TBCreateAccountResult + } + deriving (Show, Eq) + +instance Storable TBCreateAccountsResult where + sizeOf _ = #{size tb_create_accounts_result_t} + + alignment _ = #{alignment tb_create_accounts_result_t} + + peek ptr = do + tbCreateAccountsResultIndex <- #{peek tb_create_accounts_result_t, index} ptr + tbCreateAccountsResultResult <- unmarshallTBCreateAccountResult <$> #{peek tb_create_accounts_result_t, result} ptr + pure TBCreateAccountsResult{..} + + poke ptr createAccountsResult = do + #{poke tb_create_accounts_result_t, index} ptr createAccountsResult.tbCreateAccountsResultIndex + #{poke tb_create_accounts_result_t, result} ptr (marshallTBCreateAccountResult $ createAccountsResult.tbCreateAccountsResultResult) + +data TBAccountFilterFlags = + Debits + | Credits + | Reversed + deriving (Eq, Ord, Show) + +instance Enum TBAccountFilterFlags where + fromEnum Debits = #const TB_ACCOUNT_FILTER_DEBITS + fromEnum Credits = #const TB_ACCOUNT_FILTER_CREDITS + fromEnum Reversed = #const TB_ACCOUNT_FILTER_REVERSED + + toEnum (#const TB_ACCOUNT_FILTER_DEBITS) = Debits + toEnum (#const TB_ACCOUNT_FILTER_CREDITS) = Credits + toEnum (#const TB_ACCOUNT_FILTER_REVERSED) = Reversed + toEnum unmatched = error $ "AccountFilterFlags.toEnum: Cannot match " ++ show unmatched + +marshallTBAccountFilterFlags :: Set TBAccountFilterFlags -> Word32 +marshallTBAccountFilterFlags = flagsToBitmask + +unmarshallTBAccountFilterFlags :: Word32 -> Set TBAccountFilterFlags +unmarshallTBAccountFilterFlags = bitmaskToFlags + +data TBAccountFilter = TBAccountFilter + { tbAccountFilterAccountId :: Word128 + , tbAccountFilterUserData128 :: Word128 + , tbAccountFilterUserData64 :: Word64 + , tbAccountFilterUserData32 :: Word32 + , tbAccountFilterCode :: Word16 + , tbAccountFilterReserved :: Vector Word8 + , tbAccountFilterTimestampMin :: Word64 + , tbAccountFilterTimestampMax :: Word64 + , tbAccountFilterLimit :: Word32 + , tbAccountFilterFlags :: Set TBAccountFilterFlags + } + deriving (Eq, Show) + +instance Storable TBAccountFilter where + sizeOf _ = #{size tb_account_filter_t} + + alignment _ = #{alignment tb_account_filter_t} + + peek ptr = do + let reservedPtr = #{ptr tb_account_filter_t, reserved} ptr + tbAccountFilterAccountId <- #{peek tb_account_filter_t, account_id} ptr + tbAccountFilterUserData128 <- #{peek tb_account_filter_t, user_data_128} ptr + tbAccountFilterUserData64 <- #{peek tb_account_filter_t, user_data_64} ptr + tbAccountFilterUserData32 <- #{peek tb_account_filter_t, user_data_32} ptr + tbAccountFilterCode <- #{peek tb_account_filter_t, code} ptr + tbAccountFilterReserved <- V.generateM 58 (peekByteOff reservedPtr) + tbAccountFilterTimestampMin <- #{peek tb_account_filter_t, timestamp_min} ptr + tbAccountFilterTimestampMax <- #{peek tb_account_filter_t, timestamp_max} ptr + tbAccountFilterLimit <- #{peek tb_account_filter_t, limit} ptr + tbAccountFilterFlags <- unmarshallTBAccountFilterFlags <$> #{peek tb_account_filter_t, flags} ptr + pure TBAccountFilter{..} + + poke ptr accountFilter = do + #{poke tb_account_filter_t, account_id} ptr accountFilter.tbAccountFilterAccountId + #{poke tb_account_filter_t, user_data_128} ptr accountFilter.tbAccountFilterUserData128 + #{poke tb_account_filter_t, user_data_64} ptr accountFilter.tbAccountFilterUserData64 + #{poke tb_account_filter_t, user_data_32} ptr accountFilter.tbAccountFilterUserData32 + #{poke tb_account_filter_t, code} ptr accountFilter.tbAccountFilterCode + #{poke tb_account_filter_t, timestamp_min} ptr accountFilter.tbAccountFilterTimestampMin + #{poke tb_account_filter_t, timestamp_max} ptr accountFilter.tbAccountFilterTimestampMax + #{poke tb_account_filter_t, limit} ptr accountFilter.tbAccountFilterLimit + #{poke tb_account_filter_t, flags} ptr (marshallTBAccountFilterFlags accountFilter.tbAccountFilterFlags) + let reservedPtr = #{ptr tb_account_filter_t, reserved} ptr + V.iforM_ accountFilter.tbAccountFilterReserved (pokeByteOff reservedPtr) + +instance Binary TBAccountFilter where + put accountFilter = do + put $ tbAccountFilterAccountId accountFilter + put $ tbAccountFilterUserData128 accountFilter + put $ tbAccountFilterUserData64 accountFilter + putWord32le $ tbAccountFilterUserData32 accountFilter + putWord16le $ tbAccountFilterCode accountFilter + V.mapM_ putWord8 $ tbAccountFilterReserved accountFilter + putWord64le $ tbAccountFilterTimestampMin accountFilter + putWord64le $ tbAccountFilterTimestampMax accountFilter + putWord32le $ tbAccountFilterLimit accountFilter + putWord32le . marshallTBAccountFilterFlags $ tbAccountFilterFlags accountFilter + + get = do + tbAccountFilterAccountId <- get + tbAccountFilterUserData128 <- get + tbAccountFilterUserData64 <- get + tbAccountFilterUserData32 <- getWord32le + tbAccountFilterCode <- getWord16le + tbAccountFilterReserved <- V.replicateM 58 getWord8 + tbAccountFilterTimestampMin <- getWord64le + tbAccountFilterTimestampMax <- getWord64le + tbAccountFilterLimit <- getWord32le + tbAccountFilterFlags <- unmarshallTBAccountFilterFlags <$> getWord32le + return TBAccountFilter{..} + +data TBAccountBalance = TBAccountBalance + { tbAccountBalanceDebitsPending :: Word128 + , tbAccountBalanceDebitsPosted :: Word128 + , tbAccountBalanceCreditsPending :: Word128 + , tbAccountBalanceCreditsPosted :: Word128 + , tbAccountBalanceTimestamp :: Word64 + , tbAccountBalanceReserved :: Vector Word8 + } + deriving (Show, Eq) + +instance Storable TBAccountBalance where + sizeOf _ = #{size tb_account_balance_t} + + alignment _ = #{alignment tb_account_balance_t} + + peek ptr = do + let reservedPtr = #{ptr tb_account_balance_t, reserved} ptr + tbAccountBalanceDebitsPending <- #{peek tb_account_balance_t, debits_pending} ptr + tbAccountBalanceDebitsPosted <- #{peek tb_account_balance_t, debits_posted} ptr + tbAccountBalanceCreditsPending <- #{peek tb_account_balance_t, credits_pending} ptr + tbAccountBalanceCreditsPosted <- #{peek tb_account_balance_t, credits_posted} ptr + tbAccountBalanceTimestamp <- #{peek tb_account_balance_t, timestamp} ptr + tbAccountBalanceReserved <- V.generateM 56 (\i -> peekByteOff reservedPtr i) + pure TBAccountBalance{..} + + poke ptr accountBalance = do + #{poke tb_account_balance_t, debits_pending} ptr accountBalance.tbAccountBalanceDebitsPending + #{poke tb_account_balance_t, debits_posted} ptr accountBalance.tbAccountBalanceDebitsPosted + #{poke tb_account_balance_t, credits_pending} ptr accountBalance.tbAccountBalanceCreditsPending + #{poke tb_account_balance_t, credits_posted} ptr accountBalance.tbAccountBalanceCreditsPosted + #{poke tb_account_balance_t, timestamp} ptr accountBalance.tbAccountBalanceTimestamp + let reservedPtr = #{ptr tb_account_balance_t, reserved} ptr + V.iforM_ accountBalance.tbAccountBalanceReserved $ \i val -> pokeByteOff reservedPtr i val + +instance Binary TBAccountBalance where + put balance = do + put $ tbAccountBalanceDebitsPending balance + put $ tbAccountBalanceDebitsPosted balance + put $ tbAccountBalanceCreditsPending balance + put $ tbAccountBalanceCreditsPosted balance + putWord64le $ tbAccountBalanceTimestamp balance + V.mapM_ putWord8 $ tbAccountBalanceReserved balance + + get = do + tbAccountBalanceDebitsPending <- get + tbAccountBalanceDebitsPosted <- get + tbAccountBalanceCreditsPending <- get + tbAccountBalanceCreditsPosted <- get + tbAccountBalanceTimestamp <- getWord64le + tbAccountBalanceReserved <- V.replicateM 56 getWord8 + return TBAccountBalance{..} diff --git a/src/Database/TigerBeetle/Internal/FFI/BitFlag.hs b/src/Database/TigerBeetle/Internal/FFI/BitFlag.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Internal/FFI/BitFlag.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeApplications #-} + +module Database.TigerBeetle.Internal.FFI.BitFlag where + +import Data.Bits +import Data.Set (Set) +import Data.Set qualified as S + +flagsToBitmask :: forall a b. (Enum a, FiniteBits b, Num b) => Set a -> b +flagsToBitmask = S.foldr (\flag acc -> acc .|. fromIntegral (fromEnum flag)) 0 + +safeFlagsToBitmask :: forall a b. (Bounded a, Enum a, FiniteBits b, Num b) => Set a -> Maybe b +safeFlagsToBitmask s = + let enoughBitsForFlags = S.size s <= finiteBitSize @b 0 + wordIsBigEnough = fromEnum (maxBound @a) <= 2 ^ finiteBitSize @b 0 + in if enoughBitsForFlags && wordIsBigEnough + then Just $ flagsToBitmask s + else Nothing + +bitmaskToFlags :: forall b a. (Ord a, Enum a, FiniteBits b, Num b) => b -> Set a +bitmaskToFlags bitmask = + S.fromList $ + [ flag | flag <- enumFrom (toEnum 0), + -- Note: an alternate implementation could look like this, which makes the C style + -- bit flag more obvious + -- + -- (bitmask .&. fromIntegral @Int @b (fromEnum flag)) /= 0 + testBit bitmask . countTrailingZeros . fromIntegral @Int @b $ fromEnum flag + ] + +safeBitmaskToFlags + :: forall b a + . (Ord a, Bounded a, Enum a, FiniteBits b, Num b) + => b + -> Maybe (Set a) +safeBitmaskToFlags bitmask = + if fromEnum (maxBound @a) <= 2 ^ finiteBitSize @b 0 + then Just $ bitmaskToFlags bitmask + else Nothing diff --git a/src/Database/TigerBeetle/Internal/FFI/Client.hsc b/src/Database/TigerBeetle/Internal/FFI/Client.hsc new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Internal/FFI/Client.hsc @@ -0,0 +1,284 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Internal.FFI.Client where + +import Data.Word +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Data.Vector (Vector) +import Data.Vector qualified as V +import Database.TigerBeetle.ClusterId +import Database.TigerBeetle.Internal.FFI.Client.ClusterId + +#include "tb_client.h" + +data TBClient = TBClient + { tbClientOpaque :: Vector Word64 + } + deriving (Show, Eq) + +instance Storable TBClient where + sizeOf _ = #{size tb_client_t} + + alignment _ = #{alignment tb_client_t} + + peek ptr = do + let opaquePtr = #{ptr tb_client_t, opaque} ptr + tbClientOpaque <- V.generateM 4 (\i -> peekByteOff opaquePtr (i * 8)) + pure TBClient{..} + + poke ptr client = do + let opaquePtr = #{ptr tb_client_t, opaque} ptr + V.iforM_ client.tbClientOpaque $ \i val -> pokeByteOff opaquePtr (i * 8) val + +data TBInitStatus = + Success + | Unexpected + | OutOfMemory + | AddressInvalid + | AddressLimitExceeded + | SystemResources + | NetworkSubsystem + deriving (Eq, Show) + +instance Enum TBInitStatus where + fromEnum Success = #const TB_INIT_SUCCESS + fromEnum Unexpected = #const TB_INIT_UNEXPECTED + fromEnum OutOfMemory = #const TB_INIT_OUT_OF_MEMORY + fromEnum AddressInvalid = #const TB_INIT_ADDRESS_INVALID + fromEnum AddressLimitExceeded = #const TB_INIT_ADDRESS_LIMIT_EXCEEDED + fromEnum SystemResources = #const TB_INIT_SYSTEM_RESOURCES + fromEnum NetworkSubsystem = #const TB_INIT_NETWORK_SUBSYSTEM + + toEnum (#const TB_INIT_SUCCESS) = Success + toEnum (#const TB_INIT_UNEXPECTED) = Unexpected + toEnum (#const TB_INIT_OUT_OF_MEMORY) = OutOfMemory + toEnum (#const TB_INIT_ADDRESS_INVALID) = AddressInvalid + toEnum (#const TB_INIT_ADDRESS_LIMIT_EXCEEDED) = AddressLimitExceeded + toEnum (#const TB_INIT_SYSTEM_RESOURCES) = SystemResources + toEnum (#const TB_INIT_NETWORK_SUBSYSTEM) = NetworkSubsystem + toEnum unmatched = error $ "TBInitStatus.toEnum: Cannot match " ++ show unmatched + +data TBClientStatus = + ClientOk + | ClientInvalid + deriving (Eq, Show) + +instance Enum TBClientStatus where + fromEnum ClientOk = #const TB_CLIENT_OK + fromEnum ClientInvalid = #const TB_CLIENT_INVALID + + toEnum (#const TB_CLIENT_OK) = ClientOk + toEnum (#const TB_CLIENT_INVALID) = ClientInvalid + toEnum unmatched = error $ "TBClientStatus.toEnum: Cannot match " ++ show unmatched + +data TBOperation = + Pulse + | CreateAccounts + | CreateTransfers + | LookupAccounts + | LookupTransfers + | GetAccountTransfers + | GetAccountBalances + | QueryAccounts + | QueryTransfers + | GetEvents + deriving (Eq, Show) + +instance Enum TBOperation where + fromEnum Pulse = #const TB_OPERATION_PULSE + fromEnum CreateAccounts = #const TB_OPERATION_CREATE_ACCOUNTS + fromEnum CreateTransfers = #const TB_OPERATION_CREATE_TRANSFERS + fromEnum LookupAccounts = #const TB_OPERATION_LOOKUP_ACCOUNTS + fromEnum LookupTransfers = #const TB_OPERATION_LOOKUP_TRANSFERS + fromEnum GetAccountTransfers = #const TB_OPERATION_GET_ACCOUNT_TRANSFERS + fromEnum GetAccountBalances = #const TB_OPERATION_GET_ACCOUNT_BALANCES + fromEnum QueryAccounts = #const TB_OPERATION_QUERY_ACCOUNTS + fromEnum QueryTransfers = #const TB_OPERATION_QUERY_TRANSFERS + fromEnum GetEvents = #const TB_OPERATION_GET_EVENTS + + toEnum (#const TB_OPERATION_PULSE) = Pulse + toEnum (#const TB_OPERATION_CREATE_ACCOUNTS) = CreateAccounts + toEnum (#const TB_OPERATION_CREATE_TRANSFERS) = CreateTransfers + toEnum (#const TB_OPERATION_LOOKUP_ACCOUNTS) = LookupAccounts + toEnum (#const TB_OPERATION_LOOKUP_TRANSFERS) = LookupTransfers + toEnum (#const TB_OPERATION_GET_ACCOUNT_TRANSFERS) = GetAccountTransfers + toEnum (#const TB_OPERATION_GET_ACCOUNT_BALANCES) = GetAccountBalances + toEnum (#const TB_OPERATION_QUERY_ACCOUNTS) = QueryAccounts + toEnum (#const TB_OPERATION_QUERY_TRANSFERS) = QueryTransfers + toEnum (#const TB_OPERATION_GET_EVENTS) = GetEvents + toEnum unmatched = error $ "TBOperation.toEnum: Cannot match " ++ show unmatched + +marshallTBOperation :: TBOperation -> Word8 +marshallTBOperation = fromIntegral . fromEnum + +unmarshallTBOperation :: Word8 -> TBOperation +unmarshallTBOperation = toEnum . fromIntegral + +data TBPacketStatus = + Ok + | TooMuchData + | ClientEvicted + | ClientReleaseTooLow + | ClientReleaseTooHigh + | ClientShutdown + | InvalidOperation + | InvalidDataSize + deriving (Eq, Show) + +instance Enum TBPacketStatus where + fromEnum Ok = #const TB_PACKET_OK + fromEnum TooMuchData = #const TB_PACKET_TOO_MUCH_DATA + fromEnum ClientEvicted = #const TB_PACKET_CLIENT_EVICTED + fromEnum ClientReleaseTooLow = #const TB_PACKET_CLIENT_RELEASE_TOO_LOW + fromEnum ClientReleaseTooHigh = #const TB_PACKET_CLIENT_RELEASE_TOO_HIGH + fromEnum ClientShutdown = #const TB_PACKET_CLIENT_SHUTDOWN + fromEnum InvalidOperation = #const TB_PACKET_INVALID_OPERATION + fromEnum InvalidDataSize = #const TB_PACKET_INVALID_DATA_SIZE + + toEnum (#const TB_PACKET_OK) = Ok + toEnum (#const TB_PACKET_TOO_MUCH_DATA) = TooMuchData + toEnum (#const TB_PACKET_CLIENT_EVICTED) = ClientEvicted + toEnum (#const TB_PACKET_CLIENT_RELEASE_TOO_LOW) = ClientReleaseTooLow + toEnum (#const TB_PACKET_CLIENT_RELEASE_TOO_HIGH) = ClientReleaseTooHigh + toEnum (#const TB_PACKET_CLIENT_SHUTDOWN) = ClientShutdown + toEnum (#const TB_PACKET_INVALID_OPERATION) = InvalidOperation + toEnum (#const TB_PACKET_INVALID_DATA_SIZE) = InvalidDataSize + toEnum unmatched = error $ "TBPacketStatus.toEnum: Cannot match " ++ show unmatched + +marshallTBPacketStatus :: TBPacketStatus -> Word8 +marshallTBPacketStatus = fromIntegral . fromEnum + +unmarshallTBPacketStatus :: Word8 -> TBPacketStatus +unmarshallTBPacketStatus = toEnum . fromIntegral + +data TBPacket = TBPacket + { tbPacketUserData :: Ptr () + , tbPacketData :: Ptr () + , tbPacketDataSize :: Word32 + , tbPacketUserTag :: Word16 + , tbPacketOperation :: TBOperation + , tbPacketStatus :: TBPacketStatus + , tbPacketOpaque :: Vector Word8 + } + deriving (Show, Eq) + +instance Storable TBPacket where + sizeOf _ = #{size tb_packet_t} + + alignment _ = #{alignment tb_packet_t} + + peek ptr = do + tbPacketUserData <- #{peek tb_packet_t, user_data} ptr + tbPacketData <- #{peek tb_packet_t, data} ptr + tbPacketDataSize <- #{peek tb_packet_t, data_size} ptr + tbPacketUserTag <- #{peek tb_packet_t, user_tag} ptr + tbPacketOperation <- unmarshallTBOperation <$> #{peek tb_packet_t, operation} ptr + tbPacketStatus <- unmarshallTBPacketStatus <$> #{peek tb_packet_t, status} ptr + let opaquePtr = #{ptr tb_packet_t, opaque} ptr + tbPacketOpaque <- V.generateM 32 (\i -> peekByteOff opaquePtr i) + pure TBPacket{..} + + poke ptr packet = do + #{poke tb_packet_t, user_data} ptr packet.tbPacketUserData + #{poke tb_packet_t, data} ptr packet.tbPacketData + #{poke tb_packet_t, data_size} ptr packet.tbPacketDataSize + #{poke tb_packet_t, user_tag} ptr packet.tbPacketUserTag + #{poke tb_packet_t, operation} ptr (marshallTBOperation packet.tbPacketOperation) + #{poke tb_packet_t, status} ptr (marshallTBPacketStatus packet.tbPacketStatus) + let opaquePtr = #{ptr tb_packet_t, opaque} ptr + V.iforM_ packet.tbPacketOpaque $ \i val -> pokeByteOff opaquePtr i val + +type TBCompletionContext = CUIntPtr + +-- TODO: add comments explaining what these represent, asked a question in TB slack +type TBCompletionCallback = + TBCompletionContext -> + Ptr TBPacket -> + Word64 -> + Ptr Word8 -> + Word32 -> + IO () + +foreign import ccall "wrapper" + makeCompletionCallback :: TBCompletionCallback -> IO (FunPtr TBCompletionCallback) + +foreign import ccall "tb_client.h tb_client_init" + c_tb_client_init + :: Ptr TBClient + -> Ptr Word8 + -> CString + -> Word32 + -> CUIntPtr + -> FunPtr TBCompletionCallback + -> IO Word32 + +tbClientInit + :: Ptr TBClient + -> ClusterId + -> CString + -> Word32 + -> TBCompletionContext + -> FunPtr TBCompletionCallback + -> IO TBInitStatus +tbClientInit client clusterId addr addrLen ctx cb = + withClusterIdPointer clusterId $ \clusterIdPtr -> + toEnum . fromIntegral <$> c_tb_client_init client clusterIdPtr addr addrLen ctx cb + +foreign import ccall "tb_client.h tb_client_init_echo" + c_tb_client_init_echo + :: Ptr TBClient + -> Ptr Word8 + -> CString + -> Word32 + -> TBCompletionContext + -> FunPtr TBCompletionCallback + -> IO Word32 + +tbClientInitEcho + :: Ptr TBClient + -> ClusterId + -> CString + -> Word32 + -> TBCompletionContext + -> FunPtr TBCompletionCallback + -> IO TBInitStatus +tbClientInitEcho client clusterId addr addrLen ctx cb = + withClusterIdPointer clusterId $ \clusterIdPtr -> + toEnum . fromIntegral <$> c_tb_client_init_echo client clusterIdPtr addr addrLen ctx cb + +foreign import ccall "tb_client.h tb_client_completion_context" + c_tb_client_completion_context :: Ptr TBClient -> Ptr TBCompletionContext -> IO Word32 + +clientCompletionContext :: Ptr TBClient -> IO (TBClientStatus, TBCompletionContext) +clientCompletionContext client = alloca $ \ctxPtr -> do + status <- c_tb_client_completion_context client ctxPtr + ctx <- peek ctxPtr + pure (toEnum $ fromIntegral status, ctx) + +foreign import ccall "tb_client.h tb_client_submit" + c_tb_client_submit :: Ptr TBClient -> Ptr TBPacket -> IO Word32 + +tbClientSubmit :: Ptr TBClient -> Ptr TBPacket -> IO TBClientStatus +tbClientSubmit client packet = toEnum . fromIntegral <$> c_tb_client_submit client packet + +foreign import ccall "tb_client.h tb_client_deinit" + c_tb_client_deinit :: Ptr TBClient -> IO Word32 + +type TBClientFinalizerCallback + = Ptr TBClient -> IO () + +foreign import ccall "wrapper" + makeClientFinalizer :: TBClientFinalizerCallback -> IO (FunPtr TBClientFinalizerCallback) + +tbClientDeinit :: Ptr TBClient -> IO TBClientStatus +tbClientDeinit client = toEnum . fromIntegral <$> c_tb_client_deinit client diff --git a/src/Database/TigerBeetle/Internal/FFI/Client/ClusterId.hs b/src/Database/TigerBeetle/Internal/FFI/Client/ClusterId.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Internal/FFI/Client/ClusterId.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Internal.FFI.Client.ClusterId where + +import Data.WideWord +import Data.Word +import Database.TigerBeetle.ClusterId +import Foreign (Bits (..), Storable (..)) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, plusPtr) + +withClusterIdPointer :: ClusterId -> (Ptr Word8 -> IO a) -> IO a +withClusterIdPointer clusterId f = allocaBytes 16 $ \clusterIdPtr -> do + pokeClusterId clusterIdPtr clusterId.getClusterId + f clusterIdPtr + +pokeClusterId :: Ptr Word8 -> Word128 -> IO () +pokeClusterId ptr Word128{..} = + pokeWord64LE ptr word128Lo64 + >> pokeWord64LE (plusPtr ptr 8) word128Hi64 + +pokeWord64LE :: Ptr Word8 -> Word64 -> IO () +pokeWord64LE ptr w = do + pokeByteOff ptr 0 (fromIntegral (shiftR w 0) :: Word8) + pokeByteOff ptr 1 (fromIntegral (shiftR w 8) :: Word8) + pokeByteOff ptr 2 (fromIntegral (shiftR w 16) :: Word8) + pokeByteOff ptr 3 (fromIntegral (shiftR w 24) :: Word8) + pokeByteOff ptr 4 (fromIntegral (shiftR w 32) :: Word8) + pokeByteOff ptr 5 (fromIntegral (shiftR w 40) :: Word8) + pokeByteOff ptr 6 (fromIntegral (shiftR w 48) :: Word8) diff --git a/src/Database/TigerBeetle/Internal/FFI/Query.hsc b/src/Database/TigerBeetle/Internal/FFI/Query.hsc new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Internal/FFI/Query.hsc @@ -0,0 +1,110 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Internal.FFI.Query where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.WideWord +import Foreign.Ptr +import Foreign.Storable +import Data.Set (Set) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Database.TigerBeetle.Internal.FFI.BitFlag (flagsToBitmask, bitmaskToFlags) + +#include "tb_client.h" + +data TBQueryFilterFlags = + Reversed + deriving (Eq, Ord, Show) + +instance Enum TBQueryFilterFlags where + fromEnum Reversed = #const TB_QUERY_FILTER_REVERSED + + toEnum (#const TB_QUERY_FILTER_REVERSED) = Reversed + toEnum unmatched = error $ "QueryFilterFlags.toEnum: Cannot match " ++ show unmatched + +marshallTBQueryFilterFlags :: Set TBQueryFilterFlags -> Word32 +marshallTBQueryFilterFlags = flagsToBitmask + +unmarshallTBQueryFilterFlags :: Word32 -> Set TBQueryFilterFlags +unmarshallTBQueryFilterFlags = bitmaskToFlags + +data TBQueryFilter = TBQueryFilter + { tbQueryFilterUserData128 :: Word128 + , tbQueryFilterUserData64 :: Word64 + , tbQueryFilterUserData32 :: Word32 + , tbQueryFilterLedger :: Word32 + , tbQueryFilterCode :: Word16 + , tbQueryFilterReserved :: Vector Word8 + , tbQueryFilterTimestampMin :: Word64 + , tbQueryFilterTimestampMax :: Word64 + , tbQueryFilterLimit :: Word32 + , tbQueryFilterFlags :: Set TBQueryFilterFlags + } + deriving (Show, Eq) + +instance Storable TBQueryFilter where + sizeOf _ = #{size tb_query_filter_t} + + alignment _ = #{alignment tb_query_filter_t} + + peek ptr = do + let reservedPtr = #{ptr tb_query_filter_t, reserved} ptr + tbQueryFilterUserData128 <- #{peek tb_query_filter_t, user_data_128} ptr + tbQueryFilterUserData64 <- #{peek tb_query_filter_t, user_data_64} ptr + tbQueryFilterUserData32 <- #{peek tb_query_filter_t, user_data_32} ptr + tbQueryFilterLedger <- #{peek tb_query_filter_t, ledger} ptr + tbQueryFilterCode <- #{peek tb_query_filter_t, code} ptr + tbQueryFilterReserved <- V.generateM 6 (\i -> peekByteOff reservedPtr i) + tbQueryFilterTimestampMin <- #{peek tb_query_filter_t, timestamp_min} ptr + tbQueryFilterTimestampMax <- #{peek tb_query_filter_t, timestamp_max} ptr + tbQueryFilterLimit <- #{peek tb_query_filter_t, limit} ptr + tbQueryFilterFlags <- unmarshallTBQueryFilterFlags <$> #{peek tb_query_filter_t, flags} ptr + pure TBQueryFilter{..} + + poke ptr queryFilter = do + #{poke tb_query_filter_t, user_data_128} ptr queryFilter.tbQueryFilterUserData128 + #{poke tb_query_filter_t, user_data_64} ptr queryFilter.tbQueryFilterUserData64 + #{poke tb_query_filter_t, user_data_32} ptr queryFilter.tbQueryFilterUserData32 + #{poke tb_query_filter_t, ledger} ptr queryFilter.tbQueryFilterLedger + #{poke tb_query_filter_t, code} ptr queryFilter.tbQueryFilterCode + let reservedPtr = #{ptr tb_query_filter_t, reserved} ptr + V.iforM_ queryFilter.tbQueryFilterReserved $ \i val -> pokeByteOff reservedPtr i val + #{poke tb_query_filter_t, timestamp_min} ptr queryFilter.tbQueryFilterTimestampMin + #{poke tb_query_filter_t, timestamp_max} ptr queryFilter.tbQueryFilterTimestampMax + #{poke tb_query_filter_t, limit} ptr queryFilter.tbQueryFilterLimit + #{poke tb_query_filter_t, flags} ptr (marshallTBQueryFilterFlags queryFilter.tbQueryFilterFlags) + +instance Binary TBQueryFilter where + put queryfilter = do + put $ queryfilter.tbQueryFilterUserData128 + put $ queryfilter.tbQueryFilterUserData64 + putWord32le $ queryfilter.tbQueryFilterUserData32 + putWord32le $ queryfilter.tbQueryFilterLedger + putWord16le $ queryfilter.tbQueryFilterCode + V.mapM_ putWord8 $ queryfilter.tbQueryFilterReserved + putWord64le $ queryfilter.tbQueryFilterTimestampMin + putWord64le $ queryfilter.tbQueryFilterTimestampMax + putWord32le $ queryfilter.tbQueryFilterLimit + putWord32le . marshallTBQueryFilterFlags $ queryfilter.tbQueryFilterFlags + + get = do + tbQueryFilterUserData128 <- get + tbQueryFilterUserData64 <- get + tbQueryFilterUserData32 <- getWord32le + tbQueryFilterLedger <- getWord32le + tbQueryFilterCode <- getWord16le + tbQueryFilterReserved <- V.replicateM 6 getWord8 + tbQueryFilterTimestampMin <- getWord64le + tbQueryFilterTimestampMax <- getWord64le + tbQueryFilterLimit <- getWord32le + tbQueryFilterFlags <- unmarshallTBQueryFilterFlags <$> getWord32le + pure TBQueryFilter{..} diff --git a/src/Database/TigerBeetle/Internal/FFI/Transfer.hsc b/src/Database/TigerBeetle/Internal/FFI/Transfer.hsc new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Internal/FFI/Transfer.hsc @@ -0,0 +1,374 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Internal.FFI.Transfer where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.WideWord +import Data.Set (Set) +import Foreign.Storable +import Database.TigerBeetle.Internal.FFI.BitFlag (flagsToBitmask, bitmaskToFlags) + +#include "tb_client.h" + +data TBTransferFlag = + Linked + | Pending + | PostPendingTransfer + | VoidPendingTransfer + | BalancingDebit + | BalancingCredit + | ClosingDebit + | ClosingCredit + | Imported + deriving (Enum, Eq, Ord, Show) + +marshallTBTransferFlags :: Set TBTransferFlag -> Word16 +marshallTBTransferFlags = flagsToBitmask + +unmarshallTBTransferFlags :: Word16 -> Set TBTransferFlag +unmarshallTBTransferFlags = bitmaskToFlags + +data TBTransfer + = TBTransfer + { tbTransferId :: Word128 + , tbTransferDebitAccountId :: Word128 + , tbTransferCreditAccountId :: Word128 + , tbTransferAmount :: Word128 + , tbTransferPendingId :: Word128 + , tbTransferUserData128 :: Word128 + , tbTransferUserData64 :: Word64 + , tbTransferUserData32 :: Word32 + , tbTransferTimeout :: Word32 + , tbTransferLedger :: Word32 + , tbTransferCode :: Word16 + , tbTransferFlags :: Set TBTransferFlag + , tbTransferTimestamp :: Word64 + } + deriving (Eq, Show) + +instance Storable TBTransfer where + sizeOf _ = #{size tb_transfer_t} + + alignment _ = #{alignment tb_transfer_t} + + peek ptr = do + tbTransferId <- #{peek tb_transfer_t, id} ptr + tbTransferDebitAccountId <- #{peek tb_transfer_t, debit_account_id} ptr + tbTransferCreditAccountId <- #{peek tb_transfer_t, credit_account_id} ptr + tbTransferAmount <- #{peek tb_transfer_t, amount} ptr + tbTransferPendingId <- #{peek tb_transfer_t, pending_id} ptr + tbTransferUserData128 <- #{peek tb_transfer_t, user_data_128} ptr + tbTransferUserData64 <- #{peek tb_transfer_t, user_data_64} ptr + tbTransferUserData32 <- #{peek tb_transfer_t, user_data_32} ptr + tbTransferTimeout <- #{peek tb_transfer_t, timeout} ptr + tbTransferLedger <- #{peek tb_transfer_t, ledger} ptr + tbTransferCode <- #{peek tb_transfer_t, code} ptr + tbTransferFlags <- unmarshallTBTransferFlags <$> #{peek tb_transfer_t, flags} ptr + tbTransferTimestamp <- #{peek tb_transfer_t, timestamp} ptr + pure TBTransfer{..} + + poke ptr transfer = do + #{poke tb_transfer_t, id} ptr transfer.tbTransferId + #{poke tb_transfer_t, debit_account_id} ptr transfer.tbTransferDebitAccountId + #{poke tb_transfer_t, credit_account_id} ptr transfer.tbTransferCreditAccountId + #{poke tb_transfer_t, amount} ptr transfer.tbTransferAmount + #{poke tb_transfer_t, pending_id} ptr transfer.tbTransferPendingId + #{poke tb_transfer_t, user_data_128} ptr transfer.tbTransferUserData128 + #{poke tb_transfer_t, user_data_64} ptr transfer.tbTransferUserData64 + #{poke tb_transfer_t, user_data_32} ptr transfer.tbTransferUserData32 + #{poke tb_transfer_t, timeout} ptr transfer.tbTransferTimeout + #{poke tb_transfer_t, ledger} ptr transfer.tbTransferLedger + #{poke tb_transfer_t, code} ptr transfer.tbTransferCode + #{poke tb_transfer_t, flags} ptr (marshallTBTransferFlags transfer.tbTransferFlags) + #{poke tb_transfer_t, timestamp} ptr transfer.tbTransferTimestamp + +instance Binary TBTransfer where + put transfer = do + put $ transfer.tbTransferId + put $ transfer.tbTransferDebitAccountId + put $ transfer.tbTransferCreditAccountId + put $ transfer.tbTransferAmount + put $ transfer.tbTransferPendingId + put $ transfer.tbTransferUserData128 + put $ transfer.tbTransferUserData64 + putWord32le $ transfer.tbTransferUserData32 + putWord32le $ transfer.tbTransferTimeout + putWord32le $ transfer.tbTransferLedger + putWord16le $ transfer.tbTransferCode + putWord16le . marshallTBTransferFlags $ transfer.tbTransferFlags + putWord64le $ transfer.tbTransferTimestamp + + get = do + tbTransferId <- get + tbTransferDebitAccountId <- get + tbTransferCreditAccountId <- get + tbTransferAmount <- get + tbTransferPendingId <- get + tbTransferUserData128 <- get + tbTransferUserData64 <- get + tbTransferUserData32 <- getWord32le + tbTransferTimeout <- getWord32le + tbTransferLedger <- getWord32le + tbTransferCode <- getWord16le + tbTransferFlags <- unmarshallTBTransferFlags <$> getWord16le + tbTransferTimestamp <- getWord64le + return TBTransfer{..} + +data TBCreateTransferResult = + Ok + | LinkedEventFailed + | LinkedEventChainOpen + | ImportedEventExpected + | ImportedEventNotExpected + | TimestampMustBeZero + | ImportedEventTimestampOutOfRange + | ImportedEventTimestampMustNotAdvance + | ReservedFlag + | IdMustNotBeZero + | IdMustNotBeIntMax + | ExistsWithDifferentFlags + | ExistsWithDifferentPendingId + | ExistsWithDifferentTimeout + | ExistsWithDifferentDebitAccountId + | ExistsWithDifferentCreditAccountId + | ExistsWithDifferentAmount + | ExistsWithDifferentUserData128 + | ExistsWithDifferentUserData64 + | ExistsWithDifferentUserData32 + | ExistsWithDifferentLedger + | ExistsWithDifferentCode + | Exists + | IdAlreadyFailed + | FlagsAreMutuallyExclusive + | DebitAccountIdMustNotBeZero + | DebitAccountIdMustNotBeIntMax + | CreditAccountIdMustNotBeZero + | CreditAccountIdMustNotBeIntMax + | AccountsMustBeDifferent + | PendingIdMustBeZero + | PendingIdMustNotBeZero + | PendingIdMustNotBeIntMax + | PendingIdMustBeDifferent + | TimeoutReservedForPendingTransfer + | ClosingTransferMustBePending + | LedgerMustNotBeZero + | CodeMustNotBeZero + | DebitAccountNotFound + | CreditAccountNotFound + | AccountsMustHaveTheSameLedger + | TransferMustHaveTheSameLedgerAsAccounts + | PendingTransferNotFound + | PendingTransferNotPending + | PendingTransferHasDifferentDebitAccountId + | PendingTransferHasDifferentCreditAccountId + | PendingTransferHasDifferentLedger + | PendingTransferHasDifferentCode + | ExceedsPendingTransferAmount + | PendingTransferHasDifferentAmount + | PendingTransferAlreadyPosted + | PendingTransferAlreadyVoided + | PendingTransferExpired + | ImportedEventTimestampMustNotRegress + | ImportedEventTimestampMustPostdateDebitAccount + | ImportedEventTimestampMustPostdateCreditAccount + | ImportedEventTimeoutMustBeZero + | DebitAccountAlreadyClosed + | CreditAccountAlreadyClosed + | OverflowsDebitsPending + | OverflowsCreditsPending + | OverflowsDebitsPosted + | OverflowsCreditsPosted + | OverflowsDebits + | OverflowsCredits + | OverflowsTimeout + | ExceedsCredits + | ExceedsDebits + deriving (Show, Eq) + +instance Enum TBCreateTransferResult where + fromEnum Ok = #const TB_CREATE_TRANSFER_OK + fromEnum LinkedEventFailed = #const TB_CREATE_TRANSFER_LINKED_EVENT_FAILED + fromEnum LinkedEventChainOpen = #const TB_CREATE_TRANSFER_LINKED_EVENT_CHAIN_OPEN + fromEnum ImportedEventExpected = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_EXPECTED + fromEnum ImportedEventNotExpected = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_NOT_EXPECTED + fromEnum TimestampMustBeZero = #const TB_CREATE_TRANSFER_TIMESTAMP_MUST_BE_ZERO + fromEnum ImportedEventTimestampOutOfRange = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_OUT_OF_RANGE + fromEnum ImportedEventTimestampMustNotAdvance = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_ADVANCE + fromEnum ReservedFlag = #const TB_CREATE_TRANSFER_RESERVED_FLAG + fromEnum IdMustNotBeZero = #const TB_CREATE_TRANSFER_ID_MUST_NOT_BE_ZERO + fromEnum IdMustNotBeIntMax = #const TB_CREATE_TRANSFER_ID_MUST_NOT_BE_INT_MAX + fromEnum ExistsWithDifferentFlags = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_FLAGS + fromEnum ExistsWithDifferentPendingId = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_PENDING_ID + fromEnum ExistsWithDifferentTimeout = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_TIMEOUT + fromEnum ExistsWithDifferentDebitAccountId = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_DEBIT_ACCOUNT_ID + fromEnum ExistsWithDifferentCreditAccountId = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_CREDIT_ACCOUNT_ID + fromEnum ExistsWithDifferentAmount = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_AMOUNT + fromEnum ExistsWithDifferentUserData128 = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_USER_DATA_128 + fromEnum ExistsWithDifferentUserData64 = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_USER_DATA_64 + fromEnum ExistsWithDifferentUserData32 = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_USER_DATA_32 + fromEnum ExistsWithDifferentLedger = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_LEDGER + fromEnum ExistsWithDifferentCode = #const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_CODE + fromEnum Exists = #const TB_CREATE_TRANSFER_EXISTS + fromEnum IdAlreadyFailed = #const TB_CREATE_TRANSFER_ID_ALREADY_FAILED + fromEnum FlagsAreMutuallyExclusive = #const TB_CREATE_TRANSFER_FLAGS_ARE_MUTUALLY_EXCLUSIVE + fromEnum DebitAccountIdMustNotBeZero = #const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_ID_MUST_NOT_BE_ZERO + fromEnum DebitAccountIdMustNotBeIntMax = #const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_ID_MUST_NOT_BE_INT_MAX + fromEnum CreditAccountIdMustNotBeZero = #const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_ID_MUST_NOT_BE_ZERO + fromEnum CreditAccountIdMustNotBeIntMax = #const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_ID_MUST_NOT_BE_INT_MAX + fromEnum AccountsMustBeDifferent = #const TB_CREATE_TRANSFER_ACCOUNTS_MUST_BE_DIFFERENT + fromEnum PendingIdMustBeZero = #const TB_CREATE_TRANSFER_PENDING_ID_MUST_BE_ZERO + fromEnum PendingIdMustNotBeZero = #const TB_CREATE_TRANSFER_PENDING_ID_MUST_NOT_BE_ZERO + fromEnum PendingIdMustNotBeIntMax = #const TB_CREATE_TRANSFER_PENDING_ID_MUST_NOT_BE_INT_MAX + fromEnum PendingIdMustBeDifferent = #const TB_CREATE_TRANSFER_PENDING_ID_MUST_BE_DIFFERENT + fromEnum TimeoutReservedForPendingTransfer = #const TB_CREATE_TRANSFER_TIMEOUT_RESERVED_FOR_PENDING_TRANSFER + fromEnum ClosingTransferMustBePending = #const TB_CREATE_TRANSFER_CLOSING_TRANSFER_MUST_BE_PENDING + fromEnum LedgerMustNotBeZero = #const TB_CREATE_TRANSFER_LEDGER_MUST_NOT_BE_ZERO + fromEnum CodeMustNotBeZero = #const TB_CREATE_TRANSFER_CODE_MUST_NOT_BE_ZERO + fromEnum DebitAccountNotFound = #const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_NOT_FOUND + fromEnum CreditAccountNotFound = #const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_NOT_FOUND + fromEnum AccountsMustHaveTheSameLedger = #const TB_CREATE_TRANSFER_ACCOUNTS_MUST_HAVE_THE_SAME_LEDGER + fromEnum TransferMustHaveTheSameLedgerAsAccounts = #const TB_CREATE_TRANSFER_TRANSFER_MUST_HAVE_THE_SAME_LEDGER_AS_ACCOUNTS + fromEnum PendingTransferNotFound = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_NOT_FOUND + fromEnum PendingTransferNotPending = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_NOT_PENDING + fromEnum PendingTransferHasDifferentDebitAccountId = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_DEBIT_ACCOUNT_ID + fromEnum PendingTransferHasDifferentCreditAccountId = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_CREDIT_ACCOUNT_ID + fromEnum PendingTransferHasDifferentLedger = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_LEDGER + fromEnum PendingTransferHasDifferentCode = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_CODE + fromEnum ExceedsPendingTransferAmount = #const TB_CREATE_TRANSFER_EXCEEDS_PENDING_TRANSFER_AMOUNT + fromEnum PendingTransferHasDifferentAmount = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_AMOUNT + fromEnum PendingTransferAlreadyPosted = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_ALREADY_POSTED + fromEnum PendingTransferAlreadyVoided = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_ALREADY_VOIDED + fromEnum PendingTransferExpired = #const TB_CREATE_TRANSFER_PENDING_TRANSFER_EXPIRED + fromEnum ImportedEventTimestampMustNotRegress = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_REGRESS + fromEnum ImportedEventTimestampMustPostdateDebitAccount = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_POSTDATE_DEBIT_ACCOUNT + fromEnum ImportedEventTimestampMustPostdateCreditAccount = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_POSTDATE_CREDIT_ACCOUNT + fromEnum ImportedEventTimeoutMustBeZero = #const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMEOUT_MUST_BE_ZERO + fromEnum DebitAccountAlreadyClosed = #const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_ALREADY_CLOSED + fromEnum CreditAccountAlreadyClosed = #const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_ALREADY_CLOSED + fromEnum OverflowsDebitsPending = #const TB_CREATE_TRANSFER_OVERFLOWS_DEBITS_PENDING + fromEnum OverflowsCreditsPending = #const TB_CREATE_TRANSFER_OVERFLOWS_CREDITS_PENDING + fromEnum OverflowsDebitsPosted = #const TB_CREATE_TRANSFER_OVERFLOWS_DEBITS_POSTED + fromEnum OverflowsCreditsPosted = #const TB_CREATE_TRANSFER_OVERFLOWS_CREDITS_POSTED + fromEnum OverflowsDebits = #const TB_CREATE_TRANSFER_OVERFLOWS_DEBITS + fromEnum OverflowsCredits = #const TB_CREATE_TRANSFER_OVERFLOWS_CREDITS + fromEnum OverflowsTimeout = #const TB_CREATE_TRANSFER_OVERFLOWS_TIMEOUT + fromEnum ExceedsCredits = #const TB_CREATE_TRANSFER_EXCEEDS_CREDITS + fromEnum ExceedsDebits = #const TB_CREATE_TRANSFER_EXCEEDS_DEBITS + + toEnum (#const TB_CREATE_TRANSFER_OK) = Ok + toEnum (#const TB_CREATE_TRANSFER_LINKED_EVENT_FAILED) = LinkedEventFailed + toEnum (#const TB_CREATE_TRANSFER_LINKED_EVENT_CHAIN_OPEN) = LinkedEventChainOpen + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_EXPECTED) = ImportedEventExpected + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_NOT_EXPECTED) = ImportedEventNotExpected + toEnum (#const TB_CREATE_TRANSFER_TIMESTAMP_MUST_BE_ZERO) = TimestampMustBeZero + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_OUT_OF_RANGE) = ImportedEventTimestampOutOfRange + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_ADVANCE) = ImportedEventTimestampMustNotAdvance + toEnum (#const TB_CREATE_TRANSFER_RESERVED_FLAG) = ReservedFlag + toEnum (#const TB_CREATE_TRANSFER_ID_MUST_NOT_BE_ZERO) = IdMustNotBeZero + toEnum (#const TB_CREATE_TRANSFER_ID_MUST_NOT_BE_INT_MAX) = IdMustNotBeIntMax + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_FLAGS) = ExistsWithDifferentFlags + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_PENDING_ID) = ExistsWithDifferentPendingId + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_TIMEOUT) = ExistsWithDifferentTimeout + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_DEBIT_ACCOUNT_ID) = ExistsWithDifferentDebitAccountId + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_CREDIT_ACCOUNT_ID) = ExistsWithDifferentCreditAccountId + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_AMOUNT) = ExistsWithDifferentAmount + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_USER_DATA_128) = ExistsWithDifferentUserData128 + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_USER_DATA_64) = ExistsWithDifferentUserData64 + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_USER_DATA_32) = ExistsWithDifferentUserData32 + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_LEDGER) = ExistsWithDifferentLedger + toEnum (#const TB_CREATE_TRANSFER_EXISTS_WITH_DIFFERENT_CODE) = ExistsWithDifferentCode + toEnum (#const TB_CREATE_TRANSFER_EXISTS) = Exists + toEnum (#const TB_CREATE_TRANSFER_ID_ALREADY_FAILED) = IdAlreadyFailed + toEnum (#const TB_CREATE_TRANSFER_FLAGS_ARE_MUTUALLY_EXCLUSIVE) = FlagsAreMutuallyExclusive + toEnum (#const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_ID_MUST_NOT_BE_ZERO) = DebitAccountIdMustNotBeZero + toEnum (#const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_ID_MUST_NOT_BE_INT_MAX) = DebitAccountIdMustNotBeIntMax + toEnum (#const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_ID_MUST_NOT_BE_ZERO) = CreditAccountIdMustNotBeZero + toEnum (#const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_ID_MUST_NOT_BE_INT_MAX) = CreditAccountIdMustNotBeIntMax + toEnum (#const TB_CREATE_TRANSFER_ACCOUNTS_MUST_BE_DIFFERENT) = AccountsMustBeDifferent + toEnum (#const TB_CREATE_TRANSFER_PENDING_ID_MUST_BE_ZERO) = PendingIdMustBeZero + toEnum (#const TB_CREATE_TRANSFER_PENDING_ID_MUST_NOT_BE_ZERO) = PendingIdMustNotBeZero + toEnum (#const TB_CREATE_TRANSFER_PENDING_ID_MUST_NOT_BE_INT_MAX) = PendingIdMustNotBeIntMax + toEnum (#const TB_CREATE_TRANSFER_PENDING_ID_MUST_BE_DIFFERENT) = PendingIdMustBeDifferent + toEnum (#const TB_CREATE_TRANSFER_TIMEOUT_RESERVED_FOR_PENDING_TRANSFER) = TimeoutReservedForPendingTransfer + toEnum (#const TB_CREATE_TRANSFER_CLOSING_TRANSFER_MUST_BE_PENDING) = ClosingTransferMustBePending + toEnum (#const TB_CREATE_TRANSFER_LEDGER_MUST_NOT_BE_ZERO) = LedgerMustNotBeZero + toEnum (#const TB_CREATE_TRANSFER_CODE_MUST_NOT_BE_ZERO) = CodeMustNotBeZero + toEnum (#const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_NOT_FOUND) = DebitAccountNotFound + toEnum (#const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_NOT_FOUND) = CreditAccountNotFound + toEnum (#const TB_CREATE_TRANSFER_ACCOUNTS_MUST_HAVE_THE_SAME_LEDGER) = AccountsMustHaveTheSameLedger + toEnum (#const TB_CREATE_TRANSFER_TRANSFER_MUST_HAVE_THE_SAME_LEDGER_AS_ACCOUNTS) = TransferMustHaveTheSameLedgerAsAccounts + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_NOT_FOUND) = PendingTransferNotFound + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_NOT_PENDING) = PendingTransferNotPending + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_DEBIT_ACCOUNT_ID) = PendingTransferHasDifferentDebitAccountId + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_CREDIT_ACCOUNT_ID) = PendingTransferHasDifferentCreditAccountId + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_LEDGER) = PendingTransferHasDifferentLedger + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_CODE) = PendingTransferHasDifferentCode + toEnum (#const TB_CREATE_TRANSFER_EXCEEDS_PENDING_TRANSFER_AMOUNT) = ExceedsPendingTransferAmount + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_HAS_DIFFERENT_AMOUNT) = PendingTransferHasDifferentAmount + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_ALREADY_POSTED) = PendingTransferAlreadyPosted + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_ALREADY_VOIDED) = PendingTransferAlreadyVoided + toEnum (#const TB_CREATE_TRANSFER_PENDING_TRANSFER_EXPIRED) = PendingTransferExpired + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_NOT_REGRESS) = ImportedEventTimestampMustNotRegress + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_POSTDATE_DEBIT_ACCOUNT) = ImportedEventTimestampMustPostdateDebitAccount + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMESTAMP_MUST_POSTDATE_CREDIT_ACCOUNT) = ImportedEventTimestampMustPostdateCreditAccount + toEnum (#const TB_CREATE_TRANSFER_IMPORTED_EVENT_TIMEOUT_MUST_BE_ZERO) = ImportedEventTimeoutMustBeZero + toEnum (#const TB_CREATE_TRANSFER_DEBIT_ACCOUNT_ALREADY_CLOSED) = DebitAccountAlreadyClosed + toEnum (#const TB_CREATE_TRANSFER_CREDIT_ACCOUNT_ALREADY_CLOSED) = CreditAccountAlreadyClosed + toEnum (#const TB_CREATE_TRANSFER_OVERFLOWS_DEBITS_PENDING) = OverflowsDebitsPending + toEnum (#const TB_CREATE_TRANSFER_OVERFLOWS_CREDITS_PENDING) = OverflowsCreditsPending + toEnum (#const TB_CREATE_TRANSFER_OVERFLOWS_DEBITS_POSTED) = OverflowsDebitsPosted + toEnum (#const TB_CREATE_TRANSFER_OVERFLOWS_CREDITS_POSTED) = OverflowsCreditsPosted + toEnum (#const TB_CREATE_TRANSFER_OVERFLOWS_DEBITS) = OverflowsDebits + toEnum (#const TB_CREATE_TRANSFER_OVERFLOWS_CREDITS) = OverflowsCredits + toEnum (#const TB_CREATE_TRANSFER_OVERFLOWS_TIMEOUT) = OverflowsTimeout + toEnum (#const TB_CREATE_TRANSFER_EXCEEDS_CREDITS) = ExceedsCredits + toEnum (#const TB_CREATE_TRANSFER_EXCEEDS_DEBITS) = ExceedsDebits + toEnum unmatched = error $ "CreateTransfersResult.toEnum: Cannot match " ++ show unmatched + +instance Binary TBCreateTransferResult where + put = putWord32le . marshallTBCreateTransferResult + get = unmarshallTBCreateTransferResult <$> getWord32le + +marshallTBCreateTransferResult :: TBCreateTransferResult -> Word32 +marshallTBCreateTransferResult = fromIntegral . fromEnum + +unmarshallTBCreateTransferResult :: Word32 -> TBCreateTransferResult +unmarshallTBCreateTransferResult = toEnum . fromIntegral + +data TBCreateTransfersResult = TBCreateTransfersResult + { tbCreateTransfersResultIndex :: Word32 + , tbCreateTransfersResultResult :: TBCreateTransferResult + } + deriving (Show, Eq) + +instance Storable TBCreateTransfersResult where + sizeOf _ = #{size tb_create_transfers_result_t} + + alignment _ = #{alignment tb_create_transfers_result_t} + + peek ptr = do + tbCreateTransfersResultIndex <- #{peek tb_create_transfers_result_t, index} ptr + tbCreateTransfersResultResult <- unmarshallTBCreateTransferResult <$> #{peek tb_create_transfers_result_t, result} ptr + pure TBCreateTransfersResult{..} + + poke ptr createTransfersResult = do + #{poke tb_create_transfers_result_t, index} ptr createTransfersResult.tbCreateTransfersResultIndex + #{poke tb_create_transfers_result_t, result} ptr (marshallTBCreateTransferResult createTransfersResult.tbCreateTransfersResultResult) + +instance Binary TBCreateTransfersResult where + put result = do + putWord32le result.tbCreateTransfersResultIndex + put result.tbCreateTransfersResultResult + + get = do + tbCreateTransfersResultIndex <- getWord32le + tbCreateTransfersResultResult <- get + return TBCreateTransfersResult{..} diff --git a/src/Database/TigerBeetle/Ledger.hs b/src/Database/TigerBeetle/Ledger.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Ledger.hs @@ -0,0 +1,7 @@ +module Database.TigerBeetle.Ledger where + +import Data.Word + +-- | Partitions the set of accounts that can transact with each other +newtype LedgerId = LedgerId {getLedgerId :: Word32} + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Raw/Account.hs b/src/Database/TigerBeetle/Raw/Account.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Raw/Account.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Database.TigerBeetle.Raw.Account + ( module Database.TigerBeetle.Raw.Account + , TBAccount (..) + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Set qualified as S +import Data.Vector qualified as V +import Data.WideWord +import Database.TigerBeetle.Account +import Database.TigerBeetle.Internal.FFI.Account + ( TBAccount (..) + , TBAccountBalance (..) + , TBAccountFilter (..) + , TBAccountFilterFlags (..) + ) +import Database.TigerBeetle.Internal.FFI.Client +import Database.TigerBeetle.Internal.FFI.Query + ( TBQueryFilter (..) + , TBQueryFilterFlags + ) +import Database.TigerBeetle.Internal.FFI.Query qualified as Q +import Database.TigerBeetle.Ledger +import Database.TigerBeetle.Timestamp +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable + +zeroTBAccount :: IO TBAccount +zeroTBAccount = + pure $ + TBAccount + { tbAccountId = 0 + , tbAccountDebitsPending = 0 + , tbAccountDebitsPosted = 0 + , tbAccountCreditsPending = 0 + , tbAccountCreditsPosted = 0 + , tbAccountUserData128 = 0 + , tbAccountUserData64 = 0 + , tbAccountUserData32 = 0 + , tbAccountReserved = 0 + , tbAccountLedger = 0 + , tbAccountCode = 0 + , tbAccountFlags = S.empty + , tbAccountTimestamp = 0 + } + +zeroTBAccountBalance :: IO TBAccountBalance +zeroTBAccountBalance = + pure $ + TBAccountBalance + { tbAccountBalanceDebitsPending = 0 + , tbAccountBalanceDebitsPosted = 0 + , tbAccountBalanceCreditsPending = 0 + , tbAccountBalanceCreditsPosted = 0 + , tbAccountBalanceTimestamp = 0 + , tbAccountBalanceReserved = mempty + } + +-- | Create a 'TBPacket' for the @TB_OPERATION_CREATE_ACCOUNTS@ operation. +createAccounts :: (MonadIO m) => [CreateAccount] -> m (ForeignPtr TBPacket) +createAccounts accts = do + tbAccounts <- liftIO $ mapM createTBAccount accts + tbPacketPtr <- liftIO $ createAccountsPacket tbAccounts + liftIO $ newForeignPtr_ tbPacketPtr + where + createTBAccount :: CreateAccount -> IO TBAccount + createTBAccount (CreateAccount{..}) = do + tbAcct <- zeroTBAccount + pure $ + tbAcct + { tbAccountId = fromIntegral $ getAccountId createAccountId + , tbAccountLedger = getLedgerId createAccountLedger + , tbAccountCode = getAccountCode createAccountCode + } + +createAccountsPacket :: [TBAccount] -> IO (Ptr TBPacket) +createAccountsPacket accounts = do + (accountData, accountDataSize) <- pack accounts + packetPtr <- malloc + poke packetPtr $ + TBPacket + { tbPacketUserData = nullPtr + , tbPacketData = castPtr @TBAccount @() accountData + , tbPacketDataSize = fromIntegral accountDataSize + , tbPacketUserTag = 0 + , tbPacketOperation = CreateAccounts + , tbPacketStatus = Ok + , tbPacketOpaque = V.empty + } + pure packetPtr + where + pack :: [TBAccount] -> IO (Ptr TBAccount, Int) + pack accts@(a : _) = do + let dataSize = sizeOf a * length accts + tbaccounts <- mallocBytes dataSize + forM_ (zip [0 ..] accts) $ \(ix, acct) -> do + pokeElemOff tbaccounts ix acct + pure (tbaccounts, dataSize) + pack [] = error "Cannot pack an empty list of accounts" + +-- | Create a 'TBPacket' for the @TB_OPERATION_LOOKUP_ACCOUNTS@ operation. +lookupAccounts :: (MonadIO m) => [AccountId] -> m (ForeignPtr TBPacket) +lookupAccounts ids = do + tbPacketPtr <- liftIO . createLookupAccountsPacket $ map getAccountId ids + liftIO $ newForeignPtr_ tbPacketPtr + +createLookupAccountsPacket :: [Word128] -> IO (Ptr TBPacket) +createLookupAccountsPacket ids = do + (accountIdData, accountIdDataSize) <- pack ids + packetPtr <- malloc + poke packetPtr $ + TBPacket + { tbPacketUserData = nullPtr + , tbPacketData = castPtr @Word128 @() accountIdData + , tbPacketDataSize = fromIntegral accountIdDataSize + , tbPacketUserTag = 0 + , tbPacketOperation = LookupAccounts + , tbPacketStatus = Ok + , tbPacketOpaque = V.empty + } + pure packetPtr + where + pack :: [Word128] -> IO (Ptr Word128, Int) + pack acctIds@(a : _) = do + let dataSize = sizeOf a * length acctIds + tbAccountIds <- mallocBytes dataSize + forM_ (zip [0 ..] acctIds) $ \(ix, acctId) -> do + pokeElemOff tbAccountIds ix acctId + pure (tbAccountIds, dataSize) + pack [] = error "Cannot pack an empty list of account ids" + +toTBAccountFilterFlag :: AccountFlag -> TBAccountFilterFlags +toTBAccountFilterFlag = \case + AccountDebits -> Debits + AccountCredits -> Credits + AccountReversed -> Reversed + +-- | Create a 'TBPacket' for the @TB_OPERATION_GET_ACCOUNT_BALANCES@ operation. +getAccountBalances :: (MonadIO m) => [AccountBalances] -> m (ForeignPtr TBPacket) +getAccountBalances balances = do + tbPacketPtr <- liftIO $ createGetAccountBalancesPacket balances + liftIO $ newForeignPtr_ tbPacketPtr + +createGetAccountBalancesPacket :: [AccountBalances] -> IO (Ptr TBPacket) +createGetAccountBalancesPacket accountBalances = do + (accountFilterData, accountFilterDataSize) <- pack accountBalances + packetPtr <- malloc + poke packetPtr $ + TBPacket + { tbPacketUserData = nullPtr + , tbPacketData = castPtr @TBAccountFilter @() accountFilterData + , tbPacketDataSize = fromIntegral accountFilterDataSize + , tbPacketUserTag = 0 + , tbPacketOperation = GetAccountBalances + , tbPacketStatus = Ok + , tbPacketOpaque = V.empty + } + pure packetPtr + where + pack :: [AccountBalances] -> IO (Ptr TBAccountFilter, Int) + pack balanceFilters = do + let zeroAcctFilter = + TBAccountFilter + { tbAccountFilterAccountId = 0 + , tbAccountFilterUserData128 = 0 + , tbAccountFilterUserData64 = 0 + , tbAccountFilterUserData32 = 0 + , tbAccountFilterCode = 0 + , tbAccountFilterReserved = mempty + , tbAccountFilterTimestampMin = 0 + , tbAccountFilterTimestampMax = 0 + , tbAccountFilterLimit = 0 + , tbAccountFilterFlags = mempty + } + dataSize = sizeOf zeroAcctFilter * length balanceFilters + tbAccountFilters <- mallocBytes dataSize + forM_ (zip [0 ..] balanceFilters) $ \(ix, balanceFilter) -> do + let acctFilter = + TBAccountFilter + { tbAccountFilterAccountId = getAccountId balanceFilter.balancesAccountId + , tbAccountFilterUserData128 = 0 + , tbAccountFilterUserData64 = 0 + , tbAccountFilterUserData32 = 0 + , tbAccountFilterCode = 0 + , tbAccountFilterReserved = mempty + , tbAccountFilterTimestampMin = 0 + , tbAccountFilterTimestampMax = 0 + , tbAccountFilterLimit = fromIntegral balanceFilter.balancesLimit + , tbAccountFilterFlags = toTBAccountFilterFlag `S.map` balanceFilter.balancesFlags + } + pokeElemOff tbAccountFilters ix acctFilter + pure (tbAccountFilters, dataSize) + +-- | Create a 'TBPacket' for the @TB_OPERATION_GET_ACCOUNT_TRANSFERS@ operation. +getAccountTransfers :: (MonadIO m) => [AccountTransfers] -> m (ForeignPtr TBPacket) +getAccountTransfers transfers = do + tbPacketPtr <- liftIO $ createGetAccountTransfersPacket transfers + liftIO $ newForeignPtr_ tbPacketPtr + +createGetAccountTransfersPacket :: [AccountTransfers] -> IO (Ptr TBPacket) +createGetAccountTransfersPacket accountTransfers = do + (accountFilterData, accountFilterDataSize) <- pack accountTransfers + packetPtr <- malloc + poke packetPtr $ + TBPacket + { tbPacketUserData = nullPtr + , tbPacketData = castPtr @TBAccountFilter @() accountFilterData + , tbPacketDataSize = fromIntegral accountFilterDataSize + , tbPacketUserTag = 0 + , tbPacketOperation = GetAccountTransfers + , tbPacketStatus = Ok + , tbPacketOpaque = V.empty + } + pure packetPtr + where + pack :: [AccountTransfers] -> IO (Ptr TBAccountFilter, Int) + pack transfers = do + let zeroAcctFilter = + TBAccountFilter + { tbAccountFilterAccountId = 0 + , tbAccountFilterUserData128 = 0 + , tbAccountFilterUserData64 = 0 + , tbAccountFilterUserData32 = 0 + , tbAccountFilterCode = 0 + , tbAccountFilterReserved = mempty + , tbAccountFilterTimestampMin = 0 + , tbAccountFilterTimestampMax = 0 + , tbAccountFilterLimit = 0 + , tbAccountFilterFlags = mempty + } + dataSize = sizeOf zeroAcctFilter * length transfers + tbAccountFilters <- mallocBytes dataSize + forM_ (zip [0 ..] transfers) $ \(ix, transfer) -> do + let acctFilter = + TBAccountFilter + { tbAccountFilterAccountId = getAccountId transfer.transfersAccountId + , tbAccountFilterUserData128 = 0 + , tbAccountFilterUserData64 = 0 + , tbAccountFilterUserData32 = 0 + , tbAccountFilterCode = 0 + , tbAccountFilterReserved = mempty + , tbAccountFilterTimestampMin = 0 + , tbAccountFilterTimestampMax = 0 + , tbAccountFilterLimit = fromIntegral transfer.transfersLimit + , tbAccountFilterFlags = toTBAccountFilterFlag `S.map` transfer.transfersFlags + } + pokeElemOff tbAccountFilters ix acctFilter + pure (tbAccountFilters, dataSize) + +-- | Create a 'TBPacket' for the @TB_OPERATION_QUERY_ACCOUNTS@ operation. +queryAccounts :: (MonadIO m) => [AccountQuery] -> m (ForeignPtr TBPacket) +queryAccounts queries = do + tbPacketPtr <- liftIO $ queryAccountsPacket queries + liftIO $ newForeignPtr_ tbPacketPtr + +queryAccountsPacket :: [AccountQuery] -> IO (Ptr TBPacket) +queryAccountsPacket accountQueries = do + (accountFilterData, accountFilterDataSize) <- pack accountQueries + packetPtr <- malloc + poke packetPtr $ + TBPacket + { tbPacketUserData = nullPtr + , tbPacketData = castPtr @TBQueryFilter @() accountFilterData + , tbPacketDataSize = fromIntegral accountFilterDataSize + , tbPacketUserTag = 0 + , tbPacketOperation = QueryAccounts + , tbPacketStatus = Ok + , tbPacketOpaque = V.empty + } + pure packetPtr + where + pack :: [AccountQuery] -> IO (Ptr TBQueryFilter, Int) + pack queries = do + let zeroQueryFilter = + TBQueryFilter + { tbQueryFilterUserData128 = 0 + , tbQueryFilterUserData64 = 0 + , tbQueryFilterUserData32 = 0 + , tbQueryFilterLedger = 0 + , tbQueryFilterCode = 0 + , tbQueryFilterReserved = mempty + , tbQueryFilterTimestampMin = 0 + , tbQueryFilterTimestampMax = 0 + , tbQueryFilterLimit = 0 + , tbQueryFilterFlags = mempty + } + dataSize = sizeOf zeroQueryFilter * length queries + tbAccountFilters <- mallocBytes dataSize + forM_ (zip [0 ..] queries) $ \(ix, query) -> do + let acctFilter = + TBQueryFilter + { tbQueryFilterUserData128 = 0 + , tbQueryFilterUserData64 = 0 + , tbQueryFilterUserData32 = 0 + , tbQueryFilterLedger = getLedgerId query.accountQueryLedger + , tbQueryFilterCode = getAccountCode query.accountQueryCode + , tbQueryFilterReserved = mempty + , tbQueryFilterTimestampMin = getTimestamp query.accountQueryTimestampMin + , tbQueryFilterTimestampMax = getTimestamp query.accountQueryTimestampMax + , tbQueryFilterLimit = fromIntegral query.accountQueryLimit + , tbQueryFilterFlags = toTBQueryFilterFlag `S.map` query.accountQueryFlags + } + pokeElemOff tbAccountFilters ix acctFilter + pure (tbAccountFilters, dataSize) + + toTBQueryFilterFlag :: AccountQueryFlag -> TBQueryFilterFlags + toTBQueryFilterFlag = \case + AccountQueryReversed -> Q.Reversed diff --git a/src/Database/TigerBeetle/Raw/Client.hs b/src/Database/TigerBeetle/Raw/Client.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Raw/Client.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase #-} + +module Database.TigerBeetle.Raw.Client + ( -- * Types + ClientInitError (..) + , ClientPtr + + -- * Functions + , initClient + , submit + , FFI.makeCompletionCallback + ) +where + +import Control.Exception (assert) +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Text.Encoding qualified as TE +import Database.TigerBeetle.Address +import Database.TigerBeetle.ClusterId (ClusterId) +import Database.TigerBeetle.Internal.FFI.Client + ( TBClientStatus (..) + , TBCompletionCallback + , TBCompletionContext + , TBInitStatus + , TBOperation (..) + , TBPacket (..) + , TBPacketStatus (..) + ) +import Database.TigerBeetle.Internal.FFI.Client qualified as FFI +import Database.TigerBeetle.Raw.Response (DecodeResponseError) +import Foreign.C.Types (CChar) +import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr) +import Foreign.Ptr (FunPtr, Ptr) + +-- | Whether to start an echo server or a standard server +data ClientKind = Echo | Standard + deriving (Eq, Ord, Show) + +data RequestError + = ClientError TBClientStatus + | PacketError TBPacketStatus + | PacketDataParseError DecodeResponseError + | ClientShutdownDuringRequest + | RequestTimeoutError TBOperation ByteString + deriving (Eq, Show) + +withAddressPtr :: Address -> ((Ptr CChar, Int) -> IO a) -> IO a +withAddressPtr = BS.useAsCStringLen . TE.encodeUtf8 . getAddress + +data ClientInitError + = Unexpected + | OutOfMemory + | AddressInvalid + | AddressLimitExceeded + | SystemResources + | NetworkSubsystem + deriving (Eq, Show) + +-- | Create a 'Client' initialization error from a 'TBInitStatus'. +-- +-- Asserts that @err@ is not 'FFI.Success', throws an exception at +-- runtime. +toClientInitError :: TBInitStatus -> ClientInitError +toClientInitError err = assert (err /= FFI.Success) $ + case err of + FFI.Unexpected -> Unexpected + FFI.OutOfMemory -> OutOfMemory + FFI.AddressInvalid -> AddressInvalid + FFI.AddressLimitExceeded -> AddressLimitExceeded + FFI.SystemResources -> SystemResources + FFI.NetworkSubsystem -> NetworkSubsystem + FFI.Success -> error "toClientInitError: Success is not an error" + +type ClientPtr = ForeignPtr FFI.TBClient + +initClientPtr :: IO ClientPtr +initClientPtr = do + mallocForeignPtr + +validateClientInit :: ClientPtr -> TBInitStatus -> IO (Either ClientInitError ClientPtr) +validateClientInit clientPtr = \case + FFI.Success -> pure $ Right clientPtr + initError -> pure . Left . toClientInitError $ initError + +-- | Call @tb_client_init@ and return a valid 'Client' upon success. +-- +-- The finalizer on 'Client' will call @tb_client_deinit@. +initClient + :: ClusterId + -> Address + -> TBCompletionContext + -> FunPtr TBCompletionCallback + -> IO (Either ClientInitError ClientPtr) +initClient clusterId address completionCtx completionCallback = do + clientPtr <- initClientPtr + initStatus <- withForeignPtr clientPtr $ \cp -> do + withAddressPtr address $ \(addrPtr, addrLen) -> do + FFI.tbClientInit + cp + clusterId + addrPtr + (fromIntegral addrLen) + completionCtx + completionCallback + validateClientInit clientPtr initStatus + +-- | Call @tb_client_submit@ +submit :: (MonadIO m) => ClientPtr -> (a -> IO (ForeignPtr TBPacket)) -> a -> m TBClientStatus +submit clientPtr action param = do + requestPacketPtr <- liftIO $ action param + liftIO $ withForeignPtr clientPtr $ \rawClient -> do + withForeignPtr requestPacketPtr $ \rawPacket -> do + FFI.tbClientSubmit rawClient rawPacket diff --git a/src/Database/TigerBeetle/Raw/Response.hs b/src/Database/TigerBeetle/Raw/Response.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Raw/Response.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TypeApplications #-} + +module Database.TigerBeetle.Raw.Response where + +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Data.Word +import Database.TigerBeetle.Internal.FFI.Account +import Database.TigerBeetle.Internal.FFI.Client (TBOperation (..), TBPacket (..)) +import Database.TigerBeetle.Internal.FFI.Transfer hiding (Ok) +import Database.TigerBeetle.Internal.FFI.Transfer qualified as Transfer +import Database.TigerBeetle.Raw.Account (zeroTBAccount, zeroTBAccountBalance) +import Database.TigerBeetle.Raw.Transfer (zeroTBTransfer) +import Foreign.Ptr +import Foreign.Storable + +data TBResponse + = CreateAccountResultResponse [TBCreateAccountsResult] + | CreateTransferResultResponse [TBCreateTransfersResult] + | LookupAccountsResponse [TBAccount] + | LookupTransfersResponse [TBTransfer] + | GetAccountTransfersResponse [TBTransfer] + | GetAccountBalancesResponse [TBAccountBalance] + | QueryAccountsResponse [TBAccount] + | QueryTransfersResponse [TBTransfer] + deriving (Eq, Show) + +data TBResponseParseError = TBResponseParseError + { operation :: TBOperation + , rawBytes :: ByteString + , parseError :: Text + } + deriving (Eq, Show) + +data DecodeResponseError + = DecodeParseError TBResponseParseError + | DisallowedOperation + deriving (Eq, Show) + +decodeResponse :: TBPacket -> Ptr Word8 -> Int -> IO TBResponse +decodeResponse packet resultData resultLen = case packet.tbPacketOperation of + CreateAccounts -> do + let numResults = resultLen `div` sizeOf (TBCreateAccountsResult 0 Ok) + result <- (`traverse` [0 .. numResults - 1]) $ \ix -> do + peekElemOff (castPtr @Word8 @TBCreateAccountsResult resultData) ix + pure $ CreateAccountResultResponse result + LookupAccounts -> do + tbAccount <- zeroTBAccount + let numResults = resultLen `div` sizeOf tbAccount + result <- (`traverse` [0 .. numResults - 1]) $ \ix -> do + peekElemOff (castPtr @Word8 @TBAccount resultData) ix + pure $ LookupAccountsResponse result + GetAccountBalances -> do + tbAccountBalance <- zeroTBAccountBalance + let numResults = resultLen `div` sizeOf tbAccountBalance + result <- (`traverse` [0 .. numResults - 1]) $ \ix -> do + peekElemOff (castPtr @Word8 @TBAccountBalance resultData) ix + pure $ GetAccountBalancesResponse result + GetAccountTransfers -> do + tbAccountTransfer <- zeroTBTransfer + let numResults = resultLen `div` sizeOf tbAccountTransfer + result <- (`traverse` [0 .. numResults - 1]) $ \ix -> do + peekElemOff (castPtr @Word8 @TBTransfer resultData) ix + pure $ GetAccountTransfersResponse result + QueryAccounts -> do + tbAccount <- zeroTBAccount + let numResults = resultLen `div` sizeOf tbAccount + result <- (`traverse` [0 .. numResults - 1]) $ \ix -> do + peekElemOff (castPtr @Word8 @TBAccount resultData) ix + pure $ QueryAccountsResponse result + CreateTransfers -> do + let numResults = resultLen `div` sizeOf (TBCreateTransfersResult 0 Transfer.Ok) + result <- (`traverse` [0 .. numResults - 1]) $ \ix -> do + peekElemOff (castPtr @Word8 @TBCreateTransfersResult resultData) ix + pure $ CreateTransferResultResponse result + QueryTransfers -> do + tbTransfer <- zeroTBTransfer + let numResults = resultLen `div` sizeOf tbTransfer + result <- (`traverse` [0 .. numResults - 1]) $ \ix -> do + peekElemOff (castPtr @Word8 @TBTransfer resultData) ix + pure $ QueryTransfersResponse result + _ -> undefined diff --git a/src/Database/TigerBeetle/Raw/Transfer.hs b/src/Database/TigerBeetle/Raw/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Raw/Transfer.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Database.TigerBeetle.Raw.Transfer + ( module Database.TigerBeetle.Raw.Transfer + , TBTransfer (..) + , FFI.TBTransferFlag (..) + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Set qualified as Set +import Data.Vector qualified as V +import Database.TigerBeetle.Account hiding (AccountFlags (..)) +import Database.TigerBeetle.Amount +import Database.TigerBeetle.Internal.FFI.Client + ( TBOperation (..) + , TBPacket (..) + ) +import Database.TigerBeetle.Internal.FFI.Client qualified as Client +import Database.TigerBeetle.Internal.FFI.Query + ( TBQueryFilter (..) + , TBQueryFilterFlags + ) +import Database.TigerBeetle.Internal.FFI.Query qualified as Raw +import Database.TigerBeetle.Internal.FFI.Transfer (TBTransfer (..)) +import Database.TigerBeetle.Internal.FFI.Transfer qualified as FFI +import Database.TigerBeetle.Ledger +import Database.TigerBeetle.Timestamp +import Database.TigerBeetle.Transfer +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable + +zeroTBTransfer :: IO TBTransfer +zeroTBTransfer = + pure $ + TBTransfer + { tbTransferId = 0 + , tbTransferDebitAccountId = 0 + , tbTransferCreditAccountId = 0 + , tbTransferAmount = 0 + , tbTransferPendingId = 0 + , tbTransferUserData128 = 0 + , tbTransferUserData64 = 0 + , tbTransferUserData32 = 0 + , tbTransferTimeout = 0 + , tbTransferLedger = 0 + , tbTransferCode = 0 + , tbTransferFlags = mempty + , tbTransferTimestamp = 0 + } + +-- | Create a 'TBPacket' for the @TB_OPERATION_CREATE_TRANSFERS@ operation. +createTransfers :: [CreateTransfer] -> IO (ForeignPtr TBPacket) +createTransfers transfers = do + tbTransfers <- liftIO $ mapM createTBTransfer transfers + tbPacketPtr <- liftIO $ createTransfersPacket tbTransfers + liftIO $ newForeignPtr_ tbPacketPtr + where + createTBTransfer :: CreateTransfer -> IO TBTransfer + createTBTransfer CreateTransfer{..} = do + tbTransfer <- zeroTBTransfer + pure $ + tbTransfer + { tbTransferId = getTransferId createTransferId + , tbTransferDebitAccountId = getAccountId createTransferDebitAccountId + , tbTransferCreditAccountId = getAccountId createTransferCreditAccountId + , tbTransferAmount = getAmount createTransferAmount + , tbTransferPendingId = 0 + , tbTransferUserData128 = 0 + , tbTransferUserData64 = 0 + , tbTransferUserData32 = 0 + , tbTransferTimeout = 100 + , tbTransferLedger = getLedgerId createTransferLedger + , tbTransferCode = getTransferCode createTransferCode + , tbTransferFlags = toRawTransferFlags `Set.map` createTransferFlags + , tbTransferTimestamp = 0 + } + where + toRawTransferFlags :: TransferFlag -> FFI.TBTransferFlag + toRawTransferFlags = \case + Linked -> FFI.Linked + Pending -> FFI.Pending + PostPending -> FFI.PostPendingTransfer + VoidPending -> FFI.VoidPendingTransfer + BalancingDebit -> FFI.BalancingDebit + BalancingCredit -> FFI.BalancingCredit + ClosingDebit -> FFI.ClosingDebit + ClosingCredit -> FFI.ClosingCredit + Imported -> FFI.Imported + +createTransfersPacket :: [TBTransfer] -> IO (Ptr TBPacket) +createTransfersPacket transfers = do + (transferData, transferDataSize) <- pack transfers + packetPtr <- malloc + poke packetPtr $ + TBPacket + { tbPacketUserData = nullPtr + , tbPacketData = castPtr @TBTransfer @() transferData + , tbPacketDataSize = fromIntegral transferDataSize + , tbPacketUserTag = 0 + , tbPacketOperation = CreateTransfers + , tbPacketStatus = Client.Ok + , tbPacketOpaque = V.empty + } + pure packetPtr + where + pack :: [TBTransfer] -> IO (Ptr TBTransfer, Int) + pack ts@(a : _) = do + let dataSize = sizeOf a * length ts + tbtransfers <- mallocBytes dataSize + forM_ (zip [0 ..] ts) $ \(ix, transfer) -> do + pokeElemOff tbtransfers ix transfer + pure (tbtransfers, dataSize) + pack [] = error "Cannot pack an empty list of transfers" + +-- | Create a 'TBPacket' for the @TB_OPERATION_QUERY_TRANSFERS@ operation. +queryTransfers :: [TransferQuery] -> IO (ForeignPtr TBPacket) +queryTransfers transferQueries = do + tbPacketPtr <- liftIO $ queryTransfersPacket transferQueries + liftIO $ newForeignPtr_ tbPacketPtr + +queryTransfersPacket :: [TransferQuery] -> IO (Ptr TBPacket) +queryTransfersPacket transferQueries = do + (transferFilterData, transferFilterDataSize) <- pack transferQueries + packetPtr <- malloc + poke packetPtr $ + TBPacket + { tbPacketUserData = nullPtr + , tbPacketData = castPtr @TBQueryFilter @() transferFilterData + , tbPacketDataSize = fromIntegral transferFilterDataSize + , tbPacketUserTag = 0 + , tbPacketOperation = QueryTransfers + , tbPacketStatus = Client.Ok + , tbPacketOpaque = V.empty + } + pure packetPtr + where + pack :: [TransferQuery] -> IO (Ptr TBQueryFilter, Int) + pack queries = do + let zeroQueryFilter = + TBQueryFilter + { tbQueryFilterUserData128 = 0 + , tbQueryFilterUserData64 = 0 + , tbQueryFilterUserData32 = 0 + , tbQueryFilterLedger = 0 + , tbQueryFilterCode = 0 + , tbQueryFilterReserved = mempty + , tbQueryFilterTimestampMin = 0 + , tbQueryFilterTimestampMax = 0 + , tbQueryFilterLimit = 0 + , tbQueryFilterFlags = mempty + } + dataSize = sizeOf zeroQueryFilter * length queries + tbAccountFilters <- mallocBytes dataSize + forM_ (zip [0 ..] queries) $ \(ix, query) -> do + let acctFilter = + TBQueryFilter + { tbQueryFilterUserData128 = 0 + , tbQueryFilterUserData64 = 0 + , tbQueryFilterUserData32 = 0 + , tbQueryFilterLedger = fromIntegral query.queryTransferLedger -- TODO: refactor + , tbQueryFilterCode = fromIntegral query.queryTransferCode -- TODO: refactor + , tbQueryFilterReserved = mempty + , tbQueryFilterTimestampMin = getTimestamp query.queryTransferTimestampMin + , tbQueryFilterTimestampMax = getTimestamp query.queryTransferTimestampMax + , tbQueryFilterLimit = fromIntegral query.queryTransferLimit + , tbQueryFilterFlags = toTBQueryFilterFlag `Set.map` query.queryTransferFlags + } + pokeElemOff tbAccountFilters ix acctFilter + pure (tbAccountFilters, dataSize) + + toTBQueryFilterFlag :: TransferQueryFlag -> TBQueryFilterFlags + toTBQueryFilterFlag = \case + Reversed -> Raw.Reversed diff --git a/src/Database/TigerBeetle/Response.hs b/src/Database/TigerBeetle/Response.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Response.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.TigerBeetle.Response + ( Response (..) + + -- * Internal functions + , toResponse + ) +where + +import Data.Set qualified as Set +import Database.TigerBeetle.Account +import Database.TigerBeetle.Code +import Database.TigerBeetle.Internal.FFI.Account qualified as FFA +import Database.TigerBeetle.Internal.FFI.Transfer qualified as FFT +import Database.TigerBeetle.Ledger +import Database.TigerBeetle.Raw.Response qualified as Raw +import Database.TigerBeetle.Response.Account (CreateAccountsResult) +import Database.TigerBeetle.Response.Account qualified as RA +import Database.TigerBeetle.Response.Transfer (CreateTransfersResult) +import Database.TigerBeetle.Response.Transfer qualified as TA +import Database.TigerBeetle.Timestamp +import Database.TigerBeetle.Transfer (Transfer (..), TransferId (..)) +import Database.TigerBeetle.Transfer qualified as T + +-- | The responses from each of the database commands. +data Response + = CreateAccountResultResponse [CreateAccountsResult] + | CreateTransferResultResponse [CreateTransfersResult] + | LookupAccountsResponse [Account] + | LookupTransfersResponse [Transfer] + | GetAccountTransfersResponse [Transfer] + | GetAccountBalancesResponse [AccountBalance] + | QueryAccountsResponse [Account] + | QueryTransfersResponse [Transfer] + deriving (Eq, Show) + +-- TODO: Move to an internal module +toResponse :: Raw.TBResponse -> Response +toResponse = \case + Raw.CreateAccountResultResponse xs -> + CreateAccountResultResponse $ map toCreateAccountsResult xs + Raw.CreateTransferResultResponse xs -> + CreateTransferResultResponse $ map toCreateTransfersResult xs + Raw.LookupAccountsResponse xs -> + LookupAccountsResponse $ map toAccount xs + Raw.LookupTransfersResponse xs -> + LookupTransfersResponse $ map toTransfer xs + Raw.GetAccountTransfersResponse xs -> + GetAccountTransfersResponse $ map toTransfer xs + Raw.GetAccountBalancesResponse xs -> + GetAccountBalancesResponse $ map toAccountBalance xs + Raw.QueryAccountsResponse xs -> + QueryAccountsResponse $ map toAccount xs + Raw.QueryTransfersResponse xs -> + QueryTransfersResponse $ map toTransfer xs + +toAccount :: FFA.TBAccount -> Account +toAccount FFA.TBAccount{..} = + Account + { accountId = AccountId tbAccountId + , accountDebitsPending = fromIntegral tbAccountDebitsPending + , accountDebitsPosted = fromIntegral tbAccountDebitsPosted + , accountCreditsPending = fromIntegral tbAccountCreditsPending + , accountCreditsPosted = fromIntegral tbAccountCreditsPosted + , accountLedger = LedgerId tbAccountLedger + , accountCode = Code tbAccountCode + , accountFlags = Set.map toAccountFlag tbAccountFlags + , accountTimestamp = Timestamp tbAccountTimestamp + } + +toAccountFlag :: FFA.TBAccountFlags -> AccountFlags +toAccountFlag = \case + FFA.Linked -> Linked + FFA.DebitsMustNotExceedCredits -> DebitsMustNotExceedCredits + FFA.CreditsMustNotExceedDebits -> CreditsMustNotExceedDebits + FFA.History -> History + FFA.Imported -> Imported + FFA.Closed -> Closed + +toCreateAccountsResult :: FFA.TBCreateAccountsResult -> CreateAccountsResult +toCreateAccountsResult FFA.TBCreateAccountsResult{..} = + case tbCreateAccountsResultResult of + FFA.Ok -> RA.Ok + FFA.LinkedEventFailed -> RA.LinkedEventFailed + FFA.LinkedEventChainOpen -> RA.LinkedEventChainOpen + FFA.ImportedEventExpected -> RA.ImportedEventExpected + FFA.ImportedEventNotExpected -> RA.ImportedEventNotExpected + FFA.TimestampMustBeZero -> RA.TimestampMustBeZero + FFA.ImportedEventTimestampOutOfRange -> RA.ImportedEventTimestampOutOfRange + FFA.ImportedEventTimestampMustNotAdvance -> RA.ImportedEventTimestampMustNotAdvance + FFA.ReservedField -> RA.ReservedField + FFA.ReservedFlag -> RA.ReservedFlag + FFA.IdMustNotBeZero -> RA.IdMustNotBeZero + FFA.IdMustNotBeIntMax -> RA.IdMustNotBeIntMax + FFA.ExistsWithDifferentFlags -> RA.ExistsWithDifferentFlags + FFA.ExistsWithDifferentUserData128 -> RA.ExistsWithDifferentUserData128 + FFA.ExistsWithDifferentUserData64 -> RA.ExistsWithDifferentUserData64 + FFA.ExistsWithDifferentUserData32 -> RA.ExistsWithDifferentUserData32 + FFA.ExistsWithDifferentLedger -> RA.ExistsWithDifferentLedger + FFA.ExistsWithDifferentCode -> RA.ExistsWithDifferentCode + FFA.Exists -> RA.Exists + FFA.FlagsAreMutuallyExclusive -> RA.FlagsAreMutuallyExclusive + FFA.DebitsPendingMustBeZero -> RA.DebitsPendingMustBeZero + FFA.DebitsPostedMustBeZero -> RA.DebitsPostedMustBeZero + FFA.CreditsPendingMustBeZero -> RA.CreditsPendingMustBeZero + FFA.CreditsPostedMustBeZero -> RA.CreditsPostedMustBeZero + FFA.LedgerMustNotBeZero -> RA.LedgerMustNotBeZero + FFA.CodeMustNotBeZero -> RA.CodeMustNotBeZero + FFA.ImportedEventTimestampMustNotRegress -> RA.ImportedEventTimestampMustNotRegress + +toCreateTransfersResult :: FFT.TBCreateTransfersResult -> CreateTransfersResult +toCreateTransfersResult FFT.TBCreateTransfersResult{..} = + case tbCreateTransfersResultResult of + FFT.Ok -> TA.Ok + FFT.LinkedEventFailed -> TA.LinkedEventFailed + FFT.LinkedEventChainOpen -> TA.LinkedEventChainOpen + FFT.ImportedEventExpected -> TA.ImportedEventExpected + FFT.ImportedEventNotExpected -> TA.ImportedEventNotExpected + FFT.TimestampMustBeZero -> TA.TimestampMustBeZero + FFT.ImportedEventTimestampOutOfRange -> TA.ImportedEventTimestampOutOfRange + FFT.ImportedEventTimestampMustNotAdvance -> TA.ImportedEventTimestampMustNotAdvance + FFT.ReservedFlag -> TA.ReservedFlag + FFT.IdMustNotBeZero -> TA.IdMustNotBeZero + FFT.IdMustNotBeIntMax -> TA.IdMustNotBeIntMax + FFT.ExistsWithDifferentFlags -> TA.ExistsWithDifferentFlags + FFT.ExistsWithDifferentPendingId -> TA.ExistsWithDifferentPendingId + FFT.ExistsWithDifferentTimeout -> TA.ExistsWithDifferentTimeout + FFT.ExistsWithDifferentDebitAccountId -> TA.ExistsWithDifferentDebitAccountId + FFT.ExistsWithDifferentCreditAccountId -> TA.ExistsWithDifferentCreditAccountId + FFT.ExistsWithDifferentAmount -> TA.ExistsWithDifferentAmount + FFT.ExistsWithDifferentUserData128 -> TA.ExistsWithDifferentUserData128 + FFT.ExistsWithDifferentUserData64 -> TA.ExistsWithDifferentUserData64 + FFT.ExistsWithDifferentUserData32 -> TA.ExistsWithDifferentUserData32 + FFT.ExistsWithDifferentLedger -> TA.ExistsWithDifferentLedger + FFT.ExistsWithDifferentCode -> TA.ExistsWithDifferentCode + FFT.Exists -> TA.Exists + FFT.IdAlreadyFailed -> TA.IdAlreadyFailed + FFT.FlagsAreMutuallyExclusive -> TA.FlagsAreMutuallyExclusive + FFT.DebitAccountIdMustNotBeZero -> TA.DebitAccountIdMustNotBeZero + FFT.DebitAccountIdMustNotBeIntMax -> TA.DebitAccountIdMustNotBeIntMax + FFT.CreditAccountIdMustNotBeZero -> TA.CreditAccountIdMustNotBeZero + FFT.CreditAccountIdMustNotBeIntMax -> TA.CreditAccountIdMustNotBeIntMax + FFT.AccountsMustBeDifferent -> TA.AccountsMustBeDifferent + FFT.PendingIdMustBeZero -> TA.PendingIdMustBeZero + FFT.PendingIdMustNotBeZero -> TA.PendingIdMustNotBeZero + FFT.PendingIdMustNotBeIntMax -> TA.PendingIdMustNotBeIntMax + FFT.PendingIdMustBeDifferent -> TA.PendingIdMustBeDifferent + FFT.TimeoutReservedForPendingTransfer -> TA.TimeoutReservedForPendingTransfer + FFT.ClosingTransferMustBePending -> TA.ClosingTransferMustBePending + FFT.LedgerMustNotBeZero -> TA.LedgerMustNotBeZero + FFT.CodeMustNotBeZero -> TA.CodeMustNotBeZero + FFT.DebitAccountNotFound -> TA.DebitAccountNotFound + FFT.CreditAccountNotFound -> TA.CreditAccountNotFound + FFT.AccountsMustHaveTheSameLedger -> TA.AccountsMustHaveTheSameLedger + FFT.TransferMustHaveTheSameLedgerAsAccounts -> TA.TransferMustHaveTheSameLedgerAsAccounts + FFT.PendingTransferNotFound -> TA.PendingTransferNotFound + FFT.PendingTransferNotPending -> TA.PendingTransferNotPending + FFT.PendingTransferHasDifferentDebitAccountId -> TA.PendingTransferHasDifferentDebitAccountId + FFT.PendingTransferHasDifferentCreditAccountId -> TA.PendingTransferHasDifferentCreditAccountId + FFT.PendingTransferHasDifferentLedger -> TA.PendingTransferHasDifferentLedger + FFT.PendingTransferHasDifferentCode -> TA.PendingTransferHasDifferentCode + FFT.ExceedsPendingTransferAmount -> TA.ExceedsPendingTransferAmount + FFT.PendingTransferHasDifferentAmount -> TA.PendingTransferHasDifferentAmount + FFT.PendingTransferAlreadyPosted -> TA.PendingTransferAlreadyPosted + FFT.PendingTransferAlreadyVoided -> TA.PendingTransferAlreadyVoided + FFT.PendingTransferExpired -> TA.PendingTransferExpired + FFT.ImportedEventTimestampMustNotRegress -> TA.ImportedEventTimestampMustNotRegress + FFT.ImportedEventTimestampMustPostdateDebitAccount -> TA.ImportedEventTimestampMustPostdateDebitAccount + FFT.ImportedEventTimestampMustPostdateCreditAccount -> TA.ImportedEventTimestampMustPostdateCreditAccount + FFT.ImportedEventTimeoutMustBeZero -> TA.ImportedEventTimeoutMustBeZero + FFT.DebitAccountAlreadyClosed -> TA.DebitAccountAlreadyClosed + FFT.CreditAccountAlreadyClosed -> TA.CreditAccountAlreadyClosed + FFT.OverflowsDebitsPending -> TA.OverflowsDebitsPending + FFT.OverflowsCreditsPending -> TA.OverflowsCreditsPending + FFT.OverflowsDebitsPosted -> TA.OverflowsDebitsPosted + FFT.OverflowsCreditsPosted -> TA.OverflowsCreditsPosted + FFT.OverflowsDebits -> TA.OverflowsDebits + FFT.OverflowsCredits -> TA.OverflowsCredits + FFT.OverflowsTimeout -> TA.OverflowsTimeout + FFT.ExceedsCredits -> TA.ExceedsCredits + FFT.ExceedsDebits -> TA.ExceedsDebits + +toTransfer :: FFT.TBTransfer -> Transfer +toTransfer FFT.TBTransfer{..} = + Transfer + { transferId = TransferId tbTransferId + , transferDebitAccountId = AccountId tbTransferDebitAccountId + , transferCreditAccountId = AccountId tbTransferCreditAccountId + , transferAmount = fromIntegral tbTransferAmount + , transferPendingId = TransferId tbTransferPendingId + , transferTimeout = fromIntegral tbTransferTimeout + , transferLedger = LedgerId tbTransferLedger + , transferCode = Code tbTransferCode + , transferFlags = Set.map toTransferFlag tbTransferFlags + , transferTimestamp = Timestamp tbTransferTimestamp + } + +toTransferFlag :: FFT.TBTransferFlag -> T.TransferFlag +toTransferFlag = \case + FFT.Linked -> T.Linked + FFT.Pending -> T.Pending + FFT.PostPendingTransfer -> T.PostPending + FFT.VoidPendingTransfer -> T.VoidPending + FFT.BalancingDebit -> T.BalancingDebit + FFT.BalancingCredit -> T.BalancingCredit + FFT.ClosingDebit -> T.ClosingDebit + FFT.ClosingCredit -> T.ClosingCredit + FFT.Imported -> T.Imported + +toAccountBalance :: FFA.TBAccountBalance -> AccountBalance +toAccountBalance FFA.TBAccountBalance{..} = + AccountBalance + { accountBalanceDebitsPending = fromIntegral tbAccountBalanceDebitsPending + , accountBalanceDebitsPosted = fromIntegral tbAccountBalanceDebitsPosted + , accountBalanceCreditsPending = fromIntegral tbAccountBalanceCreditsPending + , accountBalanceCreditsPosted = fromIntegral tbAccountBalanceCreditsPosted + , accountBalanceTimestamp = Timestamp tbAccountBalanceTimestamp + } diff --git a/src/Database/TigerBeetle/Response/Account.hs b/src/Database/TigerBeetle/Response/Account.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Response/Account.hs @@ -0,0 +1,31 @@ +module Database.TigerBeetle.Response.Account where + +data CreateAccountsResult + = Ok + | LinkedEventFailed + | LinkedEventChainOpen + | ImportedEventExpected + | ImportedEventNotExpected + | TimestampMustBeZero + | ImportedEventTimestampOutOfRange + | ImportedEventTimestampMustNotAdvance + | ReservedField + | ReservedFlag + | IdMustNotBeZero + | IdMustNotBeIntMax + | ExistsWithDifferentFlags + | ExistsWithDifferentUserData128 + | ExistsWithDifferentUserData64 + | ExistsWithDifferentUserData32 + | ExistsWithDifferentLedger + | ExistsWithDifferentCode + | Exists + | FlagsAreMutuallyExclusive + | DebitsPendingMustBeZero + | DebitsPostedMustBeZero + | CreditsPendingMustBeZero + | CreditsPostedMustBeZero + | LedgerMustNotBeZero + | CodeMustNotBeZero + | ImportedEventTimestampMustNotRegress + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Response/Transfer.hs b/src/Database/TigerBeetle/Response/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Response/Transfer.hs @@ -0,0 +1,72 @@ +module Database.TigerBeetle.Response.Transfer where + +data CreateTransfersResult + = Ok + | LinkedEventFailed + | LinkedEventChainOpen + | ImportedEventExpected + | ImportedEventNotExpected + | TimestampMustBeZero + | ImportedEventTimestampOutOfRange + | ImportedEventTimestampMustNotAdvance + | ReservedFlag + | IdMustNotBeZero + | IdMustNotBeIntMax + | ExistsWithDifferentFlags + | ExistsWithDifferentPendingId + | ExistsWithDifferentTimeout + | ExistsWithDifferentDebitAccountId + | ExistsWithDifferentCreditAccountId + | ExistsWithDifferentAmount + | ExistsWithDifferentUserData128 + | ExistsWithDifferentUserData64 + | ExistsWithDifferentUserData32 + | ExistsWithDifferentLedger + | ExistsWithDifferentCode + | Exists + | IdAlreadyFailed + | FlagsAreMutuallyExclusive + | DebitAccountIdMustNotBeZero + | DebitAccountIdMustNotBeIntMax + | CreditAccountIdMustNotBeZero + | CreditAccountIdMustNotBeIntMax + | AccountsMustBeDifferent + | PendingIdMustBeZero + | PendingIdMustNotBeZero + | PendingIdMustNotBeIntMax + | PendingIdMustBeDifferent + | TimeoutReservedForPendingTransfer + | ClosingTransferMustBePending + | LedgerMustNotBeZero + | CodeMustNotBeZero + | DebitAccountNotFound + | CreditAccountNotFound + | AccountsMustHaveTheSameLedger + | TransferMustHaveTheSameLedgerAsAccounts + | PendingTransferNotFound + | PendingTransferNotPending + | PendingTransferHasDifferentDebitAccountId + | PendingTransferHasDifferentCreditAccountId + | PendingTransferHasDifferentLedger + | PendingTransferHasDifferentCode + | ExceedsPendingTransferAmount + | PendingTransferHasDifferentAmount + | PendingTransferAlreadyPosted + | PendingTransferAlreadyVoided + | PendingTransferExpired + | ImportedEventTimestampMustNotRegress + | ImportedEventTimestampMustPostdateDebitAccount + | ImportedEventTimestampMustPostdateCreditAccount + | ImportedEventTimeoutMustBeZero + | DebitAccountAlreadyClosed + | CreditAccountAlreadyClosed + | OverflowsDebitsPending + | OverflowsCreditsPending + | OverflowsDebitsPosted + | OverflowsCreditsPosted + | OverflowsDebits + | OverflowsCredits + | OverflowsTimeout + | ExceedsCredits + | ExceedsDebits + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Timestamp.hs b/src/Database/TigerBeetle/Timestamp.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Timestamp.hs @@ -0,0 +1,6 @@ +module Database.TigerBeetle.Timestamp where + +import Data.Word + +newtype Timestamp = Timestamp {getTimestamp :: Word64} + deriving (Eq, Show) diff --git a/src/Database/TigerBeetle/Transfer.hs b/src/Database/TigerBeetle/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/Database/TigerBeetle/Transfer.hs @@ -0,0 +1,66 @@ +module Database.TigerBeetle.Transfer where + +import Data.Set (Set) +import Data.WideWord +import Data.Word +import Database.TigerBeetle.Account +import Database.TigerBeetle.Amount +import Database.TigerBeetle.Code +import Database.TigerBeetle.Ledger +import Database.TigerBeetle.Timestamp + +newtype TransferId = TransferId {getTransferId :: Word128} + deriving (Eq, Show) + +newtype TransferCode = TransferCode {getTransferCode :: Word16} + deriving (Eq, Show) + +data TransferFlag + = Linked + | Pending + | PostPending + | VoidPending + | BalancingDebit + | BalancingCredit + | ClosingDebit + | ClosingCredit + | Imported + deriving (Bounded, Enum, Eq, Ord, Show) + +data Transfer = Transfer + { transferId :: TransferId + , transferDebitAccountId :: AccountId + , transferCreditAccountId :: AccountId + , transferAmount :: Integer + , transferPendingId :: TransferId + , transferTimeout :: Int + , transferLedger :: LedgerId + , transferCode :: Code + , transferFlags :: Set TransferFlag + , transferTimestamp :: Timestamp + } + deriving (Eq, Show) + +data CreateTransfer = CreateTransfer + { createTransferId :: TransferId + , createTransferDebitAccountId :: AccountId + , createTransferCreditAccountId :: AccountId + , createTransferAmount :: Amount + , createTransferLedger :: LedgerId + , createTransferCode :: TransferCode + , createTransferFlags :: Set TransferFlag + } + deriving (Eq, Show) + +data TransferQueryFlag = Reversed + deriving (Bounded, Enum, Eq, Ord, Show) + +data TransferQuery = TransferQuery + { queryTransferLedger :: Int + , queryTransferCode :: Int + , queryTransferTimestampMin :: Timestamp + , queryTransferTimestampMax :: Timestamp + , queryTransferLimit :: Int + , queryTransferFlags :: Set TransferQueryFlag + } + deriving (Eq, Show) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tigerbeetle-hs.cabal b/tigerbeetle-hs.cabal new file mode 100644 --- /dev/null +++ b/tigerbeetle-hs.cabal @@ -0,0 +1,95 @@ +cabal-version: 3.0 +name: tigerbeetle-hs +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: james@agentultra.com +author: James King +homepage: https://github.com/agentultra/tigerbeetle-hs#README +bug-reports: https://github.com/agentultra/tigerbeetle-hs/issues +synopsis: A Haskell client library for Tigerbeetle database +description: + Please see the README on GitHub at + +category: Experimental, Database +extra-doc-files: + README.md + CHANGELOG.md + LICENSE + +source-repository head + type: git + location: https://github.com/agentultra/tigerbeetle-hs + +library + exposed-modules: + Database.TigerBeetle.Account + Database.TigerBeetle.Amount + Database.TigerBeetle.Client + Database.TigerBeetle.Client.Async + Database.TigerBeetle.Client.Sync + Database.TigerBeetle.Code + Database.TigerBeetle.Internal.FFI.Account + Database.TigerBeetle.Internal.FFI.Client + Database.TigerBeetle.Ledger + Database.TigerBeetle.Raw.Account + Database.TigerBeetle.Raw.Client + Database.TigerBeetle.Raw.Transfer + Database.TigerBeetle.Response + Database.TigerBeetle.Response.Account + Database.TigerBeetle.Response.Transfer + Database.TigerBeetle.Transfer + Database.TigerBeetle.Timestamp + + pkgconfig-depends: tb_client + hs-source-dirs: src + other-modules: + Database.TigerBeetle.Address + Database.TigerBeetle.ClusterId + Database.TigerBeetle.Internal.FFI.Transfer + Database.TigerBeetle.Internal.FFI.Query + Database.TigerBeetle.Internal.FFI.Client.ClusterId + Database.TigerBeetle.Internal.FFI.BitFlag + Database.TigerBeetle.Raw.Response + + default-language: Haskell2010 + default-extensions: + DerivingStrategies GeneralizedNewtypeDeriving ImportQualifiedPost + OverloadedRecordDot OverloadedStrings ScopedTypeVariables + + ghc-options: -Wall -fwrite-ide-info + build-depends: + base ^>=4.18.0.0, + binary >=0.8.9 && <0.9, + bytestring >=0.11.5 && <0.12, + containers >=0.6.7 && <0.7, + mtl >=2.3.1 && <2.4, + stm >=2.5.1 && <2.6, + text >=2.0.2 && <2.1, + wide-word ==0.1.6.0, + vector >=0.13.1 && <0.14 + +executable tigerbeetle-hs + main-is: Main.hs + hs-source-dirs: app + default-language: Haskell2010 + extra-libraries: tb_client + ghc-options: -Wall -fwrite-ide-info + build-depends: + base ^>=4.18.0.0, + containers, + tigerbeetle-hs, + stm + +test-suite tigerbeetle-hs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + default-language: Haskell2010 + extra-libraries: tb_client + ghc-options: -Wall -fwrite-ide-info + build-depends: + base ^>=4.18.0.0, + hspec, + QuickCheck, + tigerbeetle-hs