Account.hs

{-# 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