Transfer.hs

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